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
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
module Source = struct
let hash =
Some (Tezos_crypto.Hashed.Protocol_hash.of_b58check_exn "PsParisCZo7KAh1Z1smVd9ZMZ1HHn5gkzbM94V3PLCpknFWhUAi")
let sources = Tezos_base.Protocol.
{ expected_env = V12 ;
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 let open Lwt_result_syntax in\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 =\n let+ l = list r in\n destutter equal_left l\n in\n let list_right r =\n let a, k = unpack left r in\n let+ l = list a in\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 =\n let open Lwt_result_syntax in\n 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 let* v1 = handler.get k i in\n let* v2 = handlers.get k i in\n return (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 let open Lwt_result_syntax in\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 ->\n 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\n let* v = handler.get k (i - 1) in\n 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 let* keys = list k in\n let* values =\n List.map_es\n (fun key ->\n if Compare.Int.(i = 1) then return (key, None)\n else\n let+ value = handler.get (k, key) (i - 1) in\n (key, value))\n keys\n in\n 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 = "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(* Copyright (c) 2023 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\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(** 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(** [scheme_of_hash] hash returns the supported hashing scheme\n that was used to obtain [hash]. *)\nval scheme_of_hash : t -> supported_hashes\n\nval of_hex : string -> t option\n\nval to_hex : t -> string\n\nval rpc_arg : t RPC_arg.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 {!val:encoding}. *)\nval well_known_reveal_hash : t\n\n(** The preimage of {!well_known_reveal_hash}. *)\nval well_known_reveal_preimage : string\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(* Copyright (c) 2023 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\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\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 scheme_of_hash hash =\n match hash with Blake2B _hash -> (Blake2B : supported_hashes)\n\nlet to_hex hash =\n let (`Hex hash) =\n (* The [encoding] of a hash here never, so [to_string_exn] is safe. *)\n Hex.of_string @@ Data_encoding.Binary.to_string_exn encoding hash\n in\n hash\n\nlet of_hex hex =\n let open Option_syntax in\n let* hash = Hex.to_bytes (`Hex hex) in\n Data_encoding.Binary.of_bytes_opt encoding hash\n\nlet rpc_arg =\n let construct = to_hex in\n let destruct hash =\n match of_hex hash with\n | None -> Error \"Cannot parse reveal hash\"\n | Some reveal_hash -> Ok reveal_hash\n in\n RPC_arg.make\n ~descr:\"A reveal hash\"\n ~name:\"reveal_hash\"\n ~destruct\n ~construct\n ()\n\n(** The preimage of {!well_known_reveal_hash}. *)\nlet well_known_reveal_preimage = \"\"\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}. *)\nlet well_known_reveal_hash =\n hash_string ~scheme:Blake2B [well_known_reveal_preimage]\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 (** [of_list elems] returns the Merkle list constructed with [elems]. *)\n val of_list : elt list -> 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 of_list : elt list -> 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 let open Result_syntax in\n if Compare.Int.(pos < 0 || pos >= next_pos) then\n tzfail 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 _, [] -> return 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 | _ -> tzfail Merkle_list_invalid_position\n in\n aux [] tree key\n\n let check_path path pos el expected_root =\n let open Result_syntax in\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 return (H.equal computed_root expected_root)\n else tzfail Merkle_list_invalid_position\n\n let path_depth path = List.length path\n\n let breadth_first_traversal ~leaf_func ~node_func ~empty ~res l =\n let rec aux ~depth l =\n let rec pairs acc = function\n | [] -> List.rev acc\n | [x] -> List.rev (node_func x empty :: acc)\n | x :: y :: xs -> pairs (node_func x y :: acc) xs\n in\n match pairs [] l with\n | [] -> res depth empty\n | [t] -> res depth t\n | pl -> aux ~depth:(depth + 1) pl\n in\n aux (List.map leaf_func l) ~depth:0\n\n let compute =\n breadth_first_traversal\n ~leaf_func:hash_elt\n ~node_func:hash2\n ~empty\n ~res:(fun _ x -> x)\n\n let of_list l =\n let depth, tree =\n breadth_first_traversal\n ~leaf_func:leaf_of\n ~node_func:node_of\n ~empty:Empty\n ~res:(fun d l -> (d + 1, l))\n l\n in\n {tree; depth; next_pos = List.length 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\n(** [hamming_weight bitset] returns the Hamming weight of [bitset]. *)\nval hamming_weight : t -> int\n\n(** [to_z t] Returns the sum of powers of two of the given bitset. *)\nval to_z : t -> Z.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 = 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 let open Result_syntax in\n let* () = error_when Compare.Int.(pos < 0) (Invalid_position pos) in\n return @@ Z.testbit field pos\n\nlet add field pos =\n let open Result_syntax in\n let* () = error_when Compare.Int.(pos < 0) (Invalid_position pos) in\n return @@ 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 let open Result_syntax in\n let* () = error_when Compare.Int.(length < 0) (Invalid_position length) in\n return 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\nlet hamming_weight = Z.popcount\n\nlet to_z z = z\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 module Map : Map.S with type key = key\n\n type value\n\n type view = value Map.t\n\n (** [empty ~capacity] returns a new table whose maximum capacity is given. *)\n val empty : capacity:int64 -> t\n\n (** Export a view of the given bounded cache *)\n val view : t -> view\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 module Map : Map.S with type key = key\n\n type view = value Map.t\n\n val empty : capacity:int64 -> t\n\n val view : t -> view\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 view = value Map.t\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 view t = t.events\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 tzfail\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 = "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 = "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 = "Percentage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** A value representing percentages, between 0% and 100%, inclusive.\n Precision of the representation is 0.01% *)\ntype t\n\n(* TODO #6918: Remove after P *)\nval encoding_legacy_in_o : t Data_encoding.t\n\nval encoding : t Data_encoding.t\n\n(** Rounds down to the nearest 0.01% *)\nval of_ratio_bounded : Ratio_repr.t -> t\n\nval of_q_bounded : round:[`Down | `Up] -> Q.t -> t\n\nval to_q : t -> Q.t\n\n(** [neg p] is [100% - p]. *)\nval neg : t -> t\n\nval add_bounded : t -> t -> t\n\nval sub_bounded : t -> t -> t\n\nval mul : round:[`Down | `Up] -> t -> t -> t\n\nval mul_q_bounded : round:[`Down | `Up] -> t -> Q.t -> t\n\n(** Constants *)\n\n(** 0% *)\nval p0 : t\n\n(** 5% *)\nval p5 : t\n\n(** 50% *)\nval p50 : t\n\n(** 51% *)\nval p51 : t\n\n(** 100% *)\nval p100 : t\n\nmodule Compare : sig\n val ( >= ) : t -> t -> bool\nend\n\nval convert_from_o_to_p : t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype t = int\n\n(* The factor by which to multiply the smallest non-zero representation in\n order to obtain 1%. A factor of 100 means that the precision is 0.01%. *)\nlet precision_factor = 100\n\nlet one_hundred_percent = 100 * precision_factor\n\n(* TODO #6918: Remove after P *)\nlet convert_from_o_to_p x = x * precision_factor\n\n(* TODO #6918: Remove after P *)\nlet of_int_guarded_legacy_in_o i =\n if Compare.Int.(i >= 0 && i <= 100) then Ok i\n else Error \"Value must be between 0 and 100\"\n\nlet of_int_guarded i =\n if Compare.Int.(i >= 0 && i <= one_hundred_percent) then Ok i\n else\n Error (Format.asprintf \"Value must be between 0 and %d\" one_hundred_percent)\n\nlet of_int_bounded i = Compare.Int.(max 0 (min one_hundred_percent i))\n\n(* TODO #6918: Remove after P *)\nlet encoding_legacy_in_o =\n let open Data_encoding in\n conv_with_guard (fun i -> i) of_int_guarded_legacy_in_o uint8\n\nlet encoding =\n let open Data_encoding in\n conv_with_guard (fun i -> i) of_int_guarded uint16\n\nlet of_ratio_bounded Ratio_repr.{numerator; denominator} =\n of_int_bounded (one_hundred_percent * numerator / denominator)\n\nlet of_q_bounded ~round (Q.{num; den} as q) =\n if Compare.Q.(q >= Q.one) then one_hundred_percent\n else\n (* Ensures that [to_int] doesn't overflow *)\n let div = match round with `Down -> Z.div | `Up -> Z.cdiv in\n of_int_bounded\n (Z.to_int (div (Z.mul (Z.of_int one_hundred_percent) num) den))\n\nlet to_q x = Q.of_ints x one_hundred_percent\n\nlet neg p = one_hundred_percent - p\n\nlet add_bounded p1 p2 = Compare.Int.min one_hundred_percent (p1 + p2)\n\nlet sub_bounded p1 p2 = Compare.Int.max 0 (p1 - p2)\n\nlet mul ~round a b = Q.mul (to_q a) (to_q b) |> of_q_bounded ~round\n\nlet mul_q_bounded ~round a q = Q.mul (to_q a) q |> of_q_bounded ~round\n\nlet p0 = 0\n\nlet p5 = 5 * precision_factor\n\nlet p50 = 50 * precision_factor\n\nlet p51 = 51 * precision_factor\n\nlet p100 = one_hundred_percent\n\nmodule Compare = struct\n include Compare.Int\nend\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(* Copyright (c) 2024 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\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_Ticket\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(* Copyright (c) 2024 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 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_Ticket\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 | D_Ticket ->\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_Ticket -> \"Ticket\"\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 =\n let open Result_syntax in\n function\n | \"parameter\" -> return K_parameter\n | \"storage\" -> return K_storage\n | \"code\" -> return K_code\n | \"view\" -> return K_view\n | \"False\" -> return D_False\n | \"Elt\" -> return D_Elt\n | \"Left\" -> return D_Left\n | \"None\" -> return D_None\n | \"Pair\" -> return D_Pair\n | \"Right\" -> return D_Right\n | \"Some\" -> return D_Some\n | \"True\" -> return D_True\n | \"Unit\" -> return D_Unit\n | \"Ticket\" -> return D_Ticket\n | \"Lambda_rec\" -> return D_Lambda_rec\n | \"PACK\" -> return I_PACK\n | \"UNPACK\" -> return I_UNPACK\n | \"BLAKE2B\" -> return I_BLAKE2B\n | \"SHA256\" -> return I_SHA256\n | \"SHA512\" -> return I_SHA512\n | \"ABS\" -> return I_ABS\n | \"ADD\" -> return I_ADD\n | \"AMOUNT\" -> return I_AMOUNT\n | \"AND\" -> return I_AND\n | \"BALANCE\" -> return I_BALANCE\n | \"CAR\" -> return I_CAR\n | \"CDR\" -> return I_CDR\n | \"CHAIN_ID\" -> return I_CHAIN_ID\n | \"CHECK_SIGNATURE\" -> return I_CHECK_SIGNATURE\n | \"COMPARE\" -> return I_COMPARE\n | \"CONCAT\" -> return I_CONCAT\n | \"CONS\" -> return I_CONS\n | \"CREATE_ACCOUNT\" -> return I_CREATE_ACCOUNT\n | \"CREATE_CONTRACT\" -> return I_CREATE_CONTRACT\n | \"IMPLICIT_ACCOUNT\" -> return I_IMPLICIT_ACCOUNT\n | \"DIP\" -> return I_DIP\n | \"DROP\" -> return I_DROP\n | \"DUP\" -> return I_DUP\n | \"VIEW\" -> return I_VIEW\n | \"EDIV\" -> return I_EDIV\n | \"EMPTY_BIG_MAP\" -> return I_EMPTY_BIG_MAP\n | \"EMPTY_MAP\" -> return I_EMPTY_MAP\n | \"EMPTY_SET\" -> return I_EMPTY_SET\n | \"EQ\" -> return I_EQ\n | \"EXEC\" -> return I_EXEC\n | \"APPLY\" -> return I_APPLY\n | \"FAILWITH\" -> return I_FAILWITH\n | \"GE\" -> return I_GE\n | \"GET\" -> return I_GET\n | \"GET_AND_UPDATE\" -> return I_GET_AND_UPDATE\n | \"GT\" -> return I_GT\n | \"HASH_KEY\" -> return I_HASH_KEY\n | \"IF\" -> return I_IF\n | \"IF_CONS\" -> return I_IF_CONS\n | \"IF_LEFT\" -> return I_IF_LEFT\n | \"IF_NONE\" -> return I_IF_NONE\n | \"INT\" -> return I_INT\n | \"KECCAK\" -> return I_KECCAK\n | \"LAMBDA\" -> return I_LAMBDA\n | \"LAMBDA_REC\" -> return I_LAMBDA_REC\n | \"LE\" -> return I_LE\n | \"LEFT\" -> return I_LEFT\n | \"LEVEL\" -> return I_LEVEL\n | \"LOOP\" -> return I_LOOP\n | \"LSL\" -> return I_LSL\n | \"LSR\" -> return I_LSR\n | \"LT\" -> return I_LT\n | \"MAP\" -> return I_MAP\n | \"MEM\" -> return I_MEM\n | \"MUL\" -> return I_MUL\n | \"NEG\" -> return I_NEG\n | \"NEQ\" -> return I_NEQ\n | \"NIL\" -> return I_NIL\n | \"NONE\" -> return I_NONE\n | \"NOT\" -> return I_NOT\n | \"NOW\" -> return I_NOW\n | \"MIN_BLOCK_TIME\" -> return I_MIN_BLOCK_TIME\n | \"OR\" -> return I_OR\n | \"PAIR\" -> return I_PAIR\n | \"UNPAIR\" -> return I_UNPAIR\n | \"PAIRING_CHECK\" -> return I_PAIRING_CHECK\n | \"PUSH\" -> return I_PUSH\n | \"RIGHT\" -> return I_RIGHT\n | \"SHA3\" -> return I_SHA3\n | \"SIZE\" -> return I_SIZE\n | \"SOME\" -> return I_SOME\n | \"SOURCE\" -> return I_SOURCE\n | \"SENDER\" -> return I_SENDER\n | \"SELF\" -> return I_SELF\n | \"SELF_ADDRESS\" -> return I_SELF_ADDRESS\n | \"SLICE\" -> return I_SLICE\n | \"STEPS_TO_QUOTA\" -> return I_STEPS_TO_QUOTA\n | \"SUB\" -> return I_SUB\n | \"SUB_MUTEZ\" -> return I_SUB_MUTEZ\n | \"SWAP\" -> return I_SWAP\n | \"TRANSFER_TOKENS\" -> return I_TRANSFER_TOKENS\n | \"SET_DELEGATE\" -> return I_SET_DELEGATE\n | \"UNIT\" -> return I_UNIT\n | \"UPDATE\" -> return I_UPDATE\n | \"XOR\" -> return I_XOR\n | \"ITER\" -> return I_ITER\n | \"LOOP_LEFT\" -> return I_LOOP_LEFT\n | \"ADDRESS\" -> return I_ADDRESS\n | \"CONTRACT\" -> return I_CONTRACT\n | \"ISNAT\" -> return I_ISNAT\n | \"CAST\" -> return I_CAST\n | \"RENAME\" -> return I_RENAME\n | \"SAPLING_EMPTY_STATE\" -> return I_SAPLING_EMPTY_STATE\n | \"SAPLING_VERIFY_UPDATE\" -> return I_SAPLING_VERIFY_UPDATE\n | \"DIG\" -> return I_DIG\n | \"DUG\" -> return I_DUG\n | \"NEVER\" -> return I_NEVER\n | \"VOTING_POWER\" -> return I_VOTING_POWER\n | \"TOTAL_VOTING_POWER\" -> return I_TOTAL_VOTING_POWER\n | \"TICKET\" -> return I_TICKET\n | \"TICKET_DEPRECATED\" -> return I_TICKET_DEPRECATED\n | \"READ_TICKET\" -> return I_READ_TICKET\n | \"SPLIT_TICKET\" -> return I_SPLIT_TICKET\n | \"JOIN_TICKETS\" -> return I_JOIN_TICKETS\n | \"OPEN_CHEST\" -> return I_OPEN_CHEST\n | \"EMIT\" -> return I_EMIT\n | \"BYTES\" -> return I_BYTES\n | \"NAT\" -> return I_NAT\n | \"bool\" -> return T_bool\n | \"contract\" -> return T_contract\n | \"int\" -> return T_int\n | \"key\" -> return T_key\n | \"key_hash\" -> return T_key_hash\n | \"lambda\" -> return T_lambda\n | \"list\" -> return T_list\n | \"map\" -> return T_map\n | \"big_map\" -> return T_big_map\n | \"nat\" -> return T_nat\n | \"option\" -> return T_option\n | \"or\" -> return T_or\n | \"pair\" -> return T_pair\n | \"set\" -> return T_set\n | \"signature\" -> return T_signature\n | \"string\" -> return T_string\n | \"bytes\" -> return T_bytes\n | \"mutez\" -> return T_mutez\n | \"timestamp\" -> return T_timestamp\n | \"unit\" -> return T_unit\n | \"operation\" -> return T_operation\n | \"address\" -> return T_address\n | \"tx_rollup_l2_address\" -> return T_tx_rollup_l2_address\n | \"sapling_state\" -> return T_sapling_state\n | \"sapling_transaction\" -> return T_sapling_transaction\n | \"sapling_transaction_deprecated\" -> return T_sapling_transaction_deprecated\n | \"chain_id\" -> return T_chain_id\n | \"never\" -> return T_never\n | \"bls12_381_g1\" -> return T_bls12_381_g1\n | \"bls12_381_g2\" -> return T_bls12_381_g2\n | \"bls12_381_fr\" -> return T_bls12_381_fr\n | \"ticket\" -> return T_ticket\n | \"chest_key\" -> return T_chest_key\n | \"chest\" -> return T_chest\n | \"constant\" -> return H_constant\n | n ->\n if valid_case n then tzfail (Unknown_primitive_name n)\n else tzfail (Invalid_case n)\n\nlet prims_of_strings expr =\n let open Result_syntax in\n let rec convert = function\n | (Int _ | String _ | Bytes _) as expr -> return expr\n | Prim (loc, prim, args, annot) ->\n let* prim =\n Error_monad.record_trace\n (Invalid_primitive_name (expr, loc))\n (prim_of_string prim)\n in\n let+ args = List.map_e convert args in\n Prim (loc, prim, args, annot)\n | Seq (loc, args) ->\n let+ args = List.map_e convert args in\n Seq (loc, args)\n in\n let+ expr = convert (root expr) in\n 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 (* Alpha_019 addition *)\n (\"Ticket\", D_Ticket);\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 let open Result_syntax in\n if Compare.Int.(i < 0 || i > max_value) then tzfail (Invalid_slot i)\n else return 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 let open Result_syntax in\n let* () = error_when (min < 0) (Invalid_slot min) in\n let* () = error_when (min > max_value) (Invalid_slot min) in\n let* () = error_when (count < 1) (Invalid_slot count) in\n let* () = error_when (count > max_value) (Invalid_slot count) in\n let max = min + count - 1 in\n let* () = error_when (max > max_value) (Invalid_slot max) in\n return (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 open Lwt_result_syntax in\n let rec loop ~acc ~next =\n if Compare.Int.(next > hi) then return acc\n else\n let* acc = f acc next in\n loop ~acc ~next:(next + 1)\n in\n let* acc = f init lo in\n loop ~acc ~next:(lo + 1)\n\n let rev_fold_es f init (Interval {lo; hi}) =\n let open Lwt_result_syntax in\n let rec loop ~acc ~next =\n if Compare.Int.(next < lo) then return acc\n else\n let* acc = f acc next in\n loop ~acc ~next:(next - 1)\n in\n let* acc = f init hi in\n loop ~acc ~next:(hi - 1)\nend\n\nmodule Internal_for_tests = struct\n let of_int = of_int\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 = "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 +=\n | Addition_overflow of t * t (* `Temporary *)\n | Subtraction_underflow of t * t (* `Temporary *)\n | Multiplication_overflow of t * Z.t (* `Temporary *)\n | Negative_multiplicator of t * Z.t (* `Temporary *)\n | Invalid_divisor of t * Z.t (* `Temporary *)\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 div2 : t -> t\n\n(** [mul_ratio ~rounding tez ~num ~den] returns [tez * num / den] without failing\n when [tez * num] overflows.\n [rounding] controls the rounding of the division. *)\nval mul_ratio :\n rounding:[`Down | `Up] -> t -> num:int64 -> den:int64 -> t tzresult\n\n(** [mul_ratio_z] is the same as [mul_ratio], but takes [Z.t] as arguments *)\nval mul_ratio_z :\n rounding:[`Down | `Up] -> t -> num:Z.t -> den:Z.t -> t tzresult\n\n(** [mul_q] is the same as [mul_ratio_z], but takes a [Q.t] as an argument *)\nval mul_q : rounding:[`Down | `Up] -> t -> Q.t -> t tzresult\n\n(** [mul_percentage tez percentage] returns [tez * percentage / 100].\n No errors can happen. *)\nval mul_percentage : rounding:[`Down | `Up] -> t -> Percentage.t -> t\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\nval balance_update_encoding : [`Credited of t | `Debited of 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\nlet wrap t = Tez_tag t [@@ocaml.inline always]\n\ntype error +=\n | Addition_overflow of t * t (* `Temporary *)\n | Subtraction_underflow of t * t (* `Temporary *)\n | Multiplication_overflow of t * Z.t (* `Temporary *)\n | Negative_multiplicator of t * Z.t (* `Temporary *)\n | Invalid_divisor of t * Z.t\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 wrap (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 Compare.Int64.(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 open Result_syntax in\n let (Tez_tag t1) = tez1 in\n let (Tez_tag t2) = tez2 in\n if t2 <= t1 then return (Tez_tag (Int64.sub t1 t2))\n else tzfail (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 open Result_syntax in\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 tzfail (Addition_overflow (tez1, tez2)) else return (Tez_tag t)\n\nlet ( *? ) tez m =\n let open Result_syntax in\n let (Tez_tag t) = tez in\n if m < 0L then tzfail (Negative_multiplicator (tez, Z.of_int64 m))\n else if m = 0L then return (Tez_tag 0L)\n else if t > Int64.(div max_int m) then\n tzfail (Multiplication_overflow (tez, Z.of_int64 m))\n else return (Tez_tag (Int64.mul t m))\n\nlet ( /? ) tez d =\n let open Result_syntax in\n let (Tez_tag t) = tez in\n if d <= 0L then tzfail (Invalid_divisor (tez, Z.of_int64 d))\n else return (Tez_tag (Int64.div t d))\n\nlet div2 (Tez_tag t) = Tez_tag (Int64.div t 2L)\n\nlet mul_exn t m =\n match t *? Int64.of_int m with Ok v -> v | Error _ -> invalid_arg \"mul_exn\"\n\nlet div_exn t d =\n match t /? Int64.of_int d with Ok v -> v | Error _ -> invalid_arg \"div_exn\"\n\nlet mul_ratio_z ~rounding tez ~num ~den =\n let open Result_syntax in\n let (Tez_tag t) = tez in\n if Z.(lt num zero) then tzfail (Negative_multiplicator (tez, num))\n else if Z.(leq den zero) then tzfail (Invalid_divisor (tez, den))\n else\n let numerator = Z.(mul (of_int64 t) num) in\n let z =\n match rounding with\n | `Down -> Z.div numerator den\n | `Up -> Z.cdiv numerator den\n in\n if Z.fits_int64 z then return (Tez_tag (Z.to_int64 z))\n else tzfail (Multiplication_overflow (tez, num))\n\nlet mul_ratio ~rounding tez ~num ~den =\n mul_ratio_z ~rounding tez ~num:(Z.of_int64 num) ~den:(Z.of_int64 den)\n\nlet mul_q ~rounding tez {Q.num; den} = mul_ratio_z ~rounding tez ~num ~den\n\nlet mul_percentage ~rounding (Tez_tag t) (percentage : Percentage.t) =\n let {Q.num; den} = Percentage.to_q percentage in\n (* Guaranteed to produce no errors by the invariants on {!Percentage.t}. *)\n let div' = match rounding with `Down -> Z.div | `Up -> Z.cdiv in\n Tez_tag Z.(to_int64 (div' (mul (of_int64 t) num) den))\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 balance_update_encoding =\n let open Data_encoding in\n conv\n (function\n | `Credited v -> to_mutez v | `Debited v -> Int64.neg (to_mutez v))\n ( Json.wrap_error @@ fun v ->\n if Compare.Int64.(v < 0L) then `Debited (Tez_tag (Int64.neg v))\n else `Credited (Tez_tag v) )\n int64\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 %a\"\n pp\n opa\n id\n Z.pp_print\n opb)\n ~description:\n (\"A multiplication of a \" ^ id ^ \" amount by an integer overflowed\")\n (obj2 (req \"amount\" encoding) (req \"multiplicator\" z))\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 %a\"\n pp\n opa\n id\n Z.pp_print\n opb)\n ~description:(\"Multiplication of a \" ^ id ^ \" amount by a negative integer\")\n (obj2 (req \"amount\" encoding) (req \"multiplicator\" z))\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 %a\"\n pp\n opa\n id\n Z.pp_print\n opb)\n ~description:\n (\"Multiplication of a \" ^ id ^ \" amount by a non positive integer\")\n (obj2 (req \"amount\" encoding) (req \"divisor\" z))\n (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)\n (fun (a, b) -> Invalid_divisor (a, b))\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 = "Deposits_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\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(** Type representing unstaked frozen deposits.\n\n [initial_amount] is the amount on which slashing should be based.\n [current_amount] is the current amount after slashing has happened. \n\n There is a record per cycle.\n\n The [initial_amount] may be increased during the current cycle only, when\n an unstake is requested.\n*)\ntype t = {initial_amount : Tez_repr.t; current_amount : Tez_repr.t}\n\nval encoding : t Data_encoding.t\n\nval zero : t\n\nval ( +? ) : t -> Tez_repr.t -> t tzresult\n\nval ( ++? ) : t -> t -> t tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\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\ntype t = {initial_amount : Tez_repr.t; current_amount : Tez_repr.t}\n\nlet 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))\n\nlet zero = {initial_amount = Tez_repr.zero; current_amount = Tez_repr.zero}\n\nlet ( +? ) {initial_amount; current_amount} inc =\n let open Result_syntax in\n let* initial_amount = Tez_repr.(initial_amount +? inc) in\n let+ current_amount = Tez_repr.(current_amount +? inc) in\n {initial_amount; current_amount}\n\nlet ( ++? ) {initial_amount = i1; current_amount = c1}\n {initial_amount = i2; current_amount = c2} =\n let open Result_syntax in\n let* initial_amount = Tez_repr.(i1 +? i2) in\n let+ current_amount = Tez_repr.(c1 +? c2) in\n {initial_amount; current_amount}\n" ;
} ;
{ name = "Unstaked_frozen_deposits_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(** Datatype for a map from cycle to deposits, where all unslashable cycles\n are squashed.\n\n Expected to be used for a small number of cycles at a time, typically\n bounded by [consensus_rights_delay + max_slashing_period] plus a small constant.\n\n See {!Unstaked_frozen_deposits_storage} for more info on unstaked frozen\n deposits.\n*)\n\n(** Storable version. *)\ntype t\n\n(** To be used locally, do not preserve values of this type over cycles. *)\ntype squashed = private {unslashable_cycle : Cycle_repr.t option; t : t}\n\nval empty : unslashable_cycle:Cycle_repr.t option -> squashed\n\nval encoding : t Data_encoding.t\n\n(** Once read, [t] must be converted to [squashed] with [squash_unslashable]\n to be used efficiently.\n For a given [unslashable_cycle], [squash_unslashable ~unslashable_cycle] is\n idempotent. *)\nval squash_unslashable :\n unslashable_cycle:Cycle_repr.t option -> t -> squashed tzresult\n\nval get : Cycle_repr.t -> squashed -> Deposits_repr.t\n\nval update :\n f:(Deposits_repr.t -> Deposits_repr.t tzresult) ->\n Cycle_repr.t ->\n squashed ->\n squashed tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(* Associative list acting like a map.\n Invariants:\n - the list is sorted by keys,\n - not duplicated keys. *)\ntype t = (Cycle_repr.t * Deposits_repr.t) list\n\nlet rec check_well_formed = function\n | [] -> Result_syntax.return_unit\n | (c1, _) :: (c2, _) :: _ when Cycle_repr.(c2 <= c1) ->\n Error \"Malformed unstaked frozen deposits\"\n | _ :: tl -> check_well_formed tl\n\nlet id_check_well_formed l =\n let open Result_syntax in\n let+ () = check_well_formed l in\n l\n\n(* A version of {!t} in which all cycles older than [unslashable_cycle] are\n squashed together using {!Deposits_repr.(++?)}. *)\ntype squashed = {unslashable_cycle : Cycle_repr.t option; t : t}\n\nlet empty ~unslashable_cycle = {unslashable_cycle; t = []}\n\nlet encoding =\n let open Data_encoding in\n conv_with_guard\n (fun l -> l)\n id_check_well_formed\n (list (tup2 Cycle_repr.encoding Deposits_repr.encoding))\n\nlet squash_unslashable ~unslashable_cycle t =\n let open Result_syntax in\n match (unslashable_cycle, t) with\n | Some unslashable_cycle', (c, unslashable) :: tl\n when Cycle_repr.(c <= unslashable_cycle') ->\n let rec aux unslashable = function\n | (c, d) :: tl when Cycle_repr.(c <= unslashable_cycle') ->\n let* unslashable = Deposits_repr.(unslashable ++? d) in\n aux unslashable tl\n | slashable ->\n return\n {\n unslashable_cycle;\n t = (unslashable_cycle', unslashable) :: slashable;\n }\n in\n aux unslashable tl\n | _ -> return {unslashable_cycle; t}\n\nlet normalize_cycle cycle ~unslashable_cycle =\n match unslashable_cycle with\n | None -> cycle\n | Some unslashable_cycle -> Cycle_repr.max cycle unslashable_cycle\n\nlet get cycle {unslashable_cycle; t} =\n let normalized_cycle = normalize_cycle cycle ~unslashable_cycle in\n List.assoc ~equal:Cycle_repr.( = ) normalized_cycle t\n |> Option.value ~default:Deposits_repr.zero\n\n(* not tail-rec *)\nlet rec update_t ~f ~normalized_cycle l =\n let open Result_syntax in\n match l with\n | (c, d) :: tl when Cycle_repr.(c = normalized_cycle) ->\n let+ d = f d in\n (c, d) :: tl\n | ((c, _) as hd) :: tl when Cycle_repr.(c < normalized_cycle) ->\n let+ tl = update_t ~f ~normalized_cycle tl in\n hd :: tl\n | _ ->\n let+ d = f Deposits_repr.zero in\n (normalized_cycle, d) :: l\n\nlet update ~f cycle {unslashable_cycle; t} =\n let open Result_syntax in\n let normalized_cycle = normalize_cycle cycle ~unslashable_cycle in\n let+ t = update_t ~f ~normalized_cycle t in\n {unslashable_cycle; t}\n" ;
} ;
{ name = "Staking_pseudotoken_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(** Pseudotoken used in staking.\n It represents a share of the total frozen deposits of a baker. *)\ninclude Compare.S\n\nval encoding : t Data_encoding.t\n\nval balance_update_encoding : [`Credited of t | `Debited of t] Data_encoding.t\n\nval zero : t\n\nval of_z_exn : Z.t -> t\n\nval to_int64 : t -> Int64.t\n\nval to_z : t -> Z.t\n\nval init_of_tez : Tez_repr.t -> t\n\nval ( +? ) : t -> t -> t tzresult\n\nval ( -? ) : t -> t -> t tzresult\n\nval pred : t -> t option\n\n(** See {!Tez_repr.mul_ratio}. *)\nval mul_ratio :\n rounding:[`Down | `Up] -> t -> num:int64 -> den:int64 -> t tzresult\n\nval pp : Format.formatter -> t -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 pseudotoken is not a Tez but it behaves similarly so let's reuse its operations. *)\n\ninclude Tez_repr\n\nlet of_int64_exn = of_mutez_exn\n\nlet to_int64 = to_mutez\n\nlet of_z_exn z = of_int64_exn (Z.to_int64 z)\n\nlet to_z t = Z.of_int64 (to_int64 t)\n\nlet init_of_tez tz = tz\n\nlet pred pt = sub_opt pt one_mutez\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 Result_syntax.return_unit\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 let open Result_syntax in\n match Internal.create secs with\n | Some v -> return v\n | None -> tzfail (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 let open Result_syntax in\n match Internal.create (Int64.of_int32 i) with\n | None -> tzfail Invalid_arg\n | Some iper -> (\n match Internal.mult_ iper p with\n | None -> tzfail Period_overflow\n | Some res -> return res)\n\nlet add p1 p2 =\n let open Result_syntax in\n match Internal.add_ p1 p2 with\n | None -> tzfail Period_overflow\n | Some res -> return 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 open Result_syntax in\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 return t64\n else if t64 < Time.of_seconds 0L then tzfail Timestamp_add\n else return 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 = "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 Index : Storage_description.INDEX with type t = round\n\nmodule Internal_for_tests : 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 let open Result_syntax in\n if i >= 0l then return i else tzfail (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 let open Result_syntax in\n if Compare.Int.(i < 0) then tzfail (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 tzfail (Round_overflow i)\n\nlet to_int i32 =\n let open Result_syntax in\n let i = Int32.to_int i32 in\n if Int32.(equal (of_int i) i32) then return i else tzfail (Round_overflow i)\n\nlet to_int32 t = t [@@inline]\n\nlet to_slot round ~committee_size =\n let open Result_syntax in\n let* r = to_int round in\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 let open Result_syntax in\n let* () =\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 in\n let* () =\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 in\n return {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 let open Result_syntax in\n if Compare.Int32.(round = zero) then return 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)) 2L) 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 Z.fits_int64 sum_durations then return (Z.to_int64 sum_durations)\n else tzfail (Round_too_high round)\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 open Result_syntax in\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 tzfail (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 return {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 let* current_level_offset =\n raw_level_offset_of_round round_durations ~round:(Int64.to_int32 round)\n in\n return\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 open Result_syntax in\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 let* start_of_current_level =\n Time_repr.(predecessor_timestamp +? pred_round_duration)\n in\n (* Finally, we sum the durations of the rounds at the current level l until\n reaching current [round]. *)\n let* level_offset = raw_level_offset_of_round round_durations ~round in\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 let open Result_syntax in\n let* target_offset =\n raw_level_offset_of_round round_durations ~round:considered_round\n in\n let* current_offset =\n raw_level_offset_of_round round_durations ~round:current_round\n in\n return\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 open Result_syntax in\n let round_duration =\n Durations.round_duration round_durations predecessor_round\n in\n let* start_of_current_level =\n Time_repr.(predecessor_timestamp +? round_duration)\n in\n let* diff =\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 in\n let* round_and_offset = round_and_offset round_durations ~level_offset:diff in\n return round_and_offset.round\n\nlet level_offset_of_round round_durations ~round =\n let open Result_syntax in\n let* offset = raw_level_offset_of_round round_durations ~round in\n return (Period_repr.of_seconds_exn offset)\n\nmodule Index = struct\n type t = round\n\n let path_length = 1\n\n let to_path round l = Int32.to_string round :: l\n\n let of_path = function [s] -> Int32.of_string_opt s | _ -> None\n\n let rpc_arg =\n let construct round = Int32.to_string round in\n let destruct str =\n Int32.of_string_opt str |> Option.to_result ~none:\"Cannot parse round\"\n in\n RPC_arg.make\n ~descr:\"A round integer\"\n ~name:\"block_round\"\n ~construct\n ~destruct\n ()\n\n let encoding = encoding\n\n let compare = compare\nend\n\nmodule Internal_for_tests = struct\n type round_and_offset_raw = {round : round; offset : Period_repr.t}\n\n let round_and_offset round_durations ~level_offset =\n let open Result_syntax in\n let+ v = round_and_offset round_durations ~level_offset in\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 = "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(** Return the predecessor of [l] when [l >= 2], otherwise return [None]. *)\nval pred_dontreturnzero : 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 let x = Int32.add l (Int32.of_int i) in\n assert (Compare.Int32.(x >= 0l)) ;\n x\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 pred_dontreturnzero l = if l <= 1l 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 let open Result_syntax in\n if Compare.Int32.(l >= 0l) then return l else tzfail (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 ~schema:Data_encoding.positive_int32_schema\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 = "Issuance_bonus_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** Issuance bonus.\n\n The issuance bonus is a rational but is stored as fixed point integer\n to limit the serialized size as with Q we would have no control on the size\n each component (numerator, denominator).\n\n It is expected to always be between 0 and the protocol's parametric\n constant [max_bonus].\n The int64 encoding of the bonus is made such that the approximation\n resulting of this encoding is negligible when the bonus is used in a\n context where the total supply of the network is in the order of magnitude\n of 2^50 mutez (10^15 mutez)\n*)\n\n(** An issuance bonus is a rational between zero and some [max_bonus]. *)\ntype t = private Q.t\n\n(** A [max_bonus] is a value between zero and one. *)\ntype max_bonus = private t\n\nval zero : t\n\nval encoding : t Data_encoding.t\n\nval max_bonus_encoding : max_bonus Data_encoding.t\n\n(** Getting a bonus out of rational.\n It will fail if the decoding doesn't provide a value that is valid wrt\n protocol's parametric constants\n *)\nval of_Q : max_bonus:max_bonus -> Q.t -> t tzresult\n\n(** Use only to define the [max_bonus] parameter from [Default_parameters]. *)\nval max_bonus_parameter_of_Q_exn : Q.t -> max_bonus\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype t = Q.t\n\ntype max_bonus = t\n\n(* Bonus will represent a fraction of the total supply, so its precision\n should be in the order of magnitude of the total supply. *)\n(* Order of magnitude of the total supply in mutez\n Approximately 2^50 *)\nlet bonus_unit = Q.of_int64 1_000_000_000_000_000L\n\nlet zero = Q.zero\n\nlet check_bounds ~max_bonus q = Q.(q >= zero && q <= max_bonus)\n [@@inline always]\n\ntype error += Out_of_bounds_bonus\n\nlet () =\n Error_monad.register_error_kind\n `Permanent\n ~id:\"out_of_bound_issuance_bonus\"\n ~title:\"Out of bound issuance bonus\"\n ~description:\"Computed issuance bonus is out of bound\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Computed issuance bonus is out of bound\")\n Data_encoding.unit\n (function Out_of_bounds_bonus -> Some () | _ -> None)\n (fun () -> Out_of_bounds_bonus)\n\nlet of_Q ~max_bonus q =\n let open Result_syntax in\n if check_bounds ~max_bonus q then return q else tzfail Out_of_bounds_bonus\n [@@inline always]\n\nlet of_Q_unbounded q = if check_bounds ~max_bonus:Q.one q then Some q else None\n\nlet of_int64_repr i = of_Q_unbounded Q.(div (of_int64 i) bonus_unit)\n\nlet of_int64_repr_err i =\n let open Result_syntax in\n match of_int64_repr i with\n | Some bonus -> return bonus\n | None -> fail \"Issuance bonus must be between 0 and 1\"\n\nlet to_int64_repr q = Q.(mul q bonus_unit |> to_int64)\n\nlet encoding =\n Data_encoding.conv_with_guard\n to_int64_repr\n of_int64_repr_err\n Data_encoding.int64\n\nlet max_bonus_encoding = encoding\n\nlet max_bonus_parameter_of_Q_exn q =\n match of_Q_unbounded q with\n | Some max_bonus -> max_bonus\n | None ->\n failwith \"Invalid parameter: max_bonus parameter must be between 0 and 1\"\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 incentives_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n attestation_threshold : int;\n cryptobox_parameters : Dal.parameters;\n}\n\nval dal_encoding : dal Data_encoding.t\n\ntype sc_rollup_reveal_hashing_schemes = {blake2B : Raw_level_repr.t}\n\n(** Associates reveal kinds to their activation level. *)\ntype sc_rollup_reveal_activation_level = {\n raw_data : sc_rollup_reveal_hashing_schemes;\n metadata : Raw_level_repr.t;\n dal_page : Raw_level_repr.t;\n dal_parameters : Raw_level_repr.t;\n dal_attested_slots_validity_lag : int;\n}\n\ntype sc_rollup = {\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 (* Activation's block level of reveal kinds. *)\n reveal_activation_level : sc_rollup_reveal_activation_level;\n (* Activates an updatable whitelist of stakers. Only keys in the whitelist are\n allowed to stake and publish a commitment. *)\n private_enable : bool;\n (* Activates the RISC-V pvm. *)\n riscv_pvm_enable : bool;\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 max_ticket_payload_size : int;\n}\n\ntype adaptive_rewards_params = {\n issuance_ratio_final_min : (* Minimum yearly issuance rate *) Q.t;\n issuance_ratio_final_max : (* Maximum yearly issuance rate *) Q.t;\n issuance_ratio_initial_min :\n (* Minimum yearly issuance rate at adaptive issuance activation *) Q.t;\n issuance_ratio_initial_max :\n (* Maximum yearly issuance rate at adaptive issuance activation *) Q.t;\n initial_period :\n (* Period in cycles during which the minimum and maximum yearly\n issuance rate values stay at their initial values *)\n int;\n transition_period :\n (* Period in cycles during which the minimum and maximum yearly\n issuance rate values decrease/increase until they reach their global values *)\n int;\n max_bonus : (* Maximum issuance bonus value *) Issuance_bonus_repr.max_bonus;\n growth_rate : (* Bonus value's growth rate *) Q.t;\n center_dz : (* Center for bonus *) Q.t;\n radius_dz :\n (* Minimum distance from center required for non-zero growth *) Q.t;\n}\n\ntype adaptive_issuance = {\n global_limit_of_staking_over_baking\n (* Global maximum stake tokens taken into account per baking token. Each baker can set their own lower limit. *) :\n int;\n edge_of_staking_over_delegation :\n (* Weight of staking over delegation. *) int;\n launch_ema_threshold : (* Threshold of the activation vote *) int32;\n adaptive_rewards_params :\n (* Parameters for the reward mechanism *) adaptive_rewards_params;\n activation_vote_enable :\n (* If set to true, reaching the launch_ema_threshold in the adaptive\n issuance activation vote triggers the activation of the adaptive\n inflation feature; otherwise the activation vote has no effect. *)\n bool;\n autostaking_enable :\n (* If set to true, a stake/unstake/finalize operation will be triggered for\n all delegate at end of cycle. *)\n bool;\n force_activation :\n (* For testing purposes. If set to true, the adaptive issuance feature is\n enabled without waiting to reach the launch_ema_threshold.*)\n bool;\n ns_enable : (* If set to true, enables the NS feature *)\n bool;\n}\n\ntype issuance_weights = {\n (* [base_total_issued_per_minute] is the total amount of rewards expected to\n be distributed every minute *)\n base_total_issued_per_minute : Tez_repr.t;\n (* The following fields represent the \"weights\" of the respective reward kinds.\n The actual reward values are computed proportionally from the other weights\n as a portion of the [base_total_issued_per_minute]. See the module\n {!Delegate_rewards} for more details *)\n baking_reward_fixed_portion_weight : int;\n baking_reward_bonus_weight : int;\n attesting_reward_weight : int;\n seed_nonce_revelation_tip_weight : int;\n vdf_revelation_tip_weight : int;\n}\n\ntype t = {\n (* Number of cycles after which computed consensus rights are used to actually\n participate in the consensus *)\n consensus_rights_delay : int;\n (* Number of past cycles about which the protocol hints the shell that it should\n keep them in its history. *)\n blocks_preservation_cycles : int;\n (* Number of cycles after which submitted delegate parameters are being\n used. *)\n delegate_parameters_activation_delay : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : 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 minimal_frozen_stake : Tez_repr.t;\n vdf_difficulty : int64;\n origination_size : int;\n issuance_weights : issuance_weights;\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 limit_of_delegation_over_baking : int;\n (* upper bound on the (delegated tz / own frozen tz) ratio *)\n percentage_of_frozen_deposits_slashed_per_double_baking : Percentage.t;\n percentage_of_frozen_deposits_slashed_per_double_attestation : Percentage.t;\n max_slashing_per_block : Percentage.t;\n max_slashing_threshold : int;\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 dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n adaptive_issuance : adaptive_issuance;\n direct_ticket_spending_enable : bool;\n}\n\nval encoding : t Data_encoding.encoding\n\nval update_sc_rollup_parameter : block_time:int -> sc_rollup -> sc_rollup\n\nmodule Internal_for_tests : sig\n val sc_rollup_encoding : sc_rollup Data_encoding.t\nend\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 incentives_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n attestation_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 incentives_enable;\n number_of_slots;\n attestation_lag;\n attestation_threshold;\n cryptobox_parameters;\n } ->\n ( ( feature_enable,\n incentives_enable,\n number_of_slots,\n attestation_lag,\n attestation_threshold ),\n cryptobox_parameters ))\n (fun ( ( feature_enable,\n incentives_enable,\n number_of_slots,\n attestation_lag,\n attestation_threshold ),\n cryptobox_parameters ) ->\n {\n feature_enable;\n incentives_enable;\n number_of_slots;\n attestation_lag;\n attestation_threshold;\n cryptobox_parameters;\n })\n (merge_objs\n (obj5\n (req \"feature_enable\" bool)\n (req \"incentives_enable\" bool)\n (req \"number_of_slots\" uint16)\n (req \"attestation_lag\" uint8)\n (req \"attestation_threshold\" uint8))\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 sc_rollup_reveal_hashing_schemes = {blake2B : Raw_level_repr.t}\n\ntype sc_rollup_reveal_activation_level = {\n raw_data : sc_rollup_reveal_hashing_schemes;\n metadata : Raw_level_repr.t;\n dal_page : Raw_level_repr.t;\n dal_parameters : Raw_level_repr.t;\n (* Once a DAL slot is attested, a rollup can only import it within the range\n of levels [attested_level; attested_level +\n dal_attested_slots_validity_lag]. *)\n (* Warning: the semantics of valid slots needs to be adapted if the\n value of this parameter is changed in the future.\n - If it is increased, some attested slots that were outdated with\n the old value will become valid again.\n - If it is decreased, some attested slots that were valid with\n the old value will become outdated.\n\n In both cases, the status of slots before and after the value change is\n different. Said otherwise, the validity of the slot may differ depending on\n the time of the check, in particular it may be different in the following\n two cases: (a) the slot is imported before the value upgrade, (2) a\n refutation game targeting a page of that slot is started after the\n upgrade. *)\n dal_attested_slots_validity_lag : int;\n}\n\nlet sc_rollup_reveal_hashing_schemes_encoding =\n let open Data_encoding in\n conv\n (fun t -> t.blake2B)\n (fun blake2B -> {blake2B})\n (obj1 (req \"Blake2B\" Raw_level_repr.encoding))\n\nlet sc_rollup_reveal_activation_level_encoding :\n sc_rollup_reveal_activation_level Data_encoding.t =\n let open Data_encoding in\n conv\n (fun t ->\n ( t.raw_data,\n t.metadata,\n t.dal_page,\n t.dal_parameters,\n t.dal_attested_slots_validity_lag ))\n (fun ( raw_data,\n metadata,\n dal_page,\n dal_parameters,\n dal_attested_slots_validity_lag ) ->\n {\n raw_data;\n metadata;\n dal_page;\n dal_parameters;\n dal_attested_slots_validity_lag;\n })\n (obj5\n (req \"raw_data\" sc_rollup_reveal_hashing_schemes_encoding)\n (req \"metadata\" Raw_level_repr.encoding)\n (req \"dal_page\" Raw_level_repr.encoding)\n (req \"dal_parameters\" Raw_level_repr.encoding)\n (req \"dal_attested_slots_validity_lag\" Data_encoding.int31))\n\ntype sc_rollup = {\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 reveal_activation_level : sc_rollup_reveal_activation_level;\n private_enable : bool;\n riscv_pvm_enable : bool;\n}\n\ntype zk_rollup = {\n enable : bool;\n origination_size : int;\n min_pending_to_process : int;\n max_ticket_payload_size : int;\n}\n\ntype adaptive_rewards_params = {\n issuance_ratio_final_min : Q.t;\n issuance_ratio_final_max : Q.t;\n issuance_ratio_initial_min : Q.t;\n issuance_ratio_initial_max : Q.t;\n initial_period : int;\n transition_period : int;\n max_bonus : Issuance_bonus_repr.max_bonus;\n growth_rate : Q.t;\n center_dz : Q.t;\n radius_dz : Q.t;\n}\n\ntype adaptive_issuance = {\n global_limit_of_staking_over_baking : int;\n edge_of_staking_over_delegation : int;\n launch_ema_threshold : int32;\n adaptive_rewards_params : adaptive_rewards_params;\n activation_vote_enable : bool;\n autostaking_enable : bool;\n force_activation : bool;\n ns_enable : bool;\n}\n\ntype issuance_weights = {\n base_total_issued_per_minute : Tez_repr.t;\n baking_reward_fixed_portion_weight : int;\n baking_reward_bonus_weight : int;\n attesting_reward_weight : int;\n seed_nonce_revelation_tip_weight : int;\n vdf_revelation_tip_weight : int;\n}\n\ntype t = {\n consensus_rights_delay : int;\n blocks_preservation_cycles : int;\n delegate_parameters_activation_delay : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : 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 minimal_frozen_stake : Tez_repr.t;\n vdf_difficulty : int64;\n origination_size : int;\n issuance_weights : issuance_weights;\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 limit_of_delegation_over_baking : int;\n percentage_of_frozen_deposits_slashed_per_double_baking : Percentage.t;\n percentage_of_frozen_deposits_slashed_per_double_attestation : Percentage.t;\n max_slashing_per_block : Percentage.t;\n max_slashing_threshold : int;\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 dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n adaptive_issuance : adaptive_issuance;\n direct_ticket_spending_enable : bool;\n}\n\nlet sc_rollup_encoding =\n let open Data_encoding in\n conv\n (fun (c : sc_rollup) ->\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 c.reveal_activation_level,\n c.private_enable,\n c.riscv_pvm_enable ) ))\n (fun ( ( 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 sc_rollup_reveal_activation_level,\n sc_rollup_private_enable,\n sc_rollup_riscv_pvm_enable ) ) ->\n {\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 reveal_activation_level = sc_rollup_reveal_activation_level;\n private_enable = sc_rollup_private_enable;\n riscv_pvm_enable = sc_rollup_riscv_pvm_enable;\n })\n (merge_objs\n (obj8\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 (obj7\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 (req\n \"smart_rollup_reveal_activation_level\"\n sc_rollup_reveal_activation_level_encoding)\n (req \"smart_rollup_private_enable\" bool)\n (req \"smart_rollup_riscv_pvm_enable\" bool)))\n\nlet zk_rollup_encoding =\n let open Data_encoding in\n conv\n (fun ({\n enable;\n origination_size;\n min_pending_to_process;\n max_ticket_payload_size;\n } :\n zk_rollup) ->\n (enable, origination_size, min_pending_to_process, max_ticket_payload_size))\n (fun ( zk_rollup_enable,\n zk_rollup_origination_size,\n zk_rollup_min_pending_to_process,\n zk_rollup_max_ticket_payload_size ) ->\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 max_ticket_payload_size = zk_rollup_max_ticket_payload_size;\n })\n (obj4\n (req \"zk_rollup_enable\" bool)\n (req \"zk_rollup_origination_size\" int31)\n (req \"zk_rollup_min_pending_to_process\" int31)\n (req \"zk_rollup_max_ticket_payload_size\" int31))\n\nlet extremum_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num > Z.zero && den > Z.zero) then Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Extremum Parameter: only positive values allowed\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet center_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num >= Z.zero && den > Z.zero && num <= den) then\n Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Parameter: dead zone center can only be between 0 \\\n and 1\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet radius_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num >= Z.zero && den > Z.zero) then Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Parameter: dead zone radius must be non-negative\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet growth_rate_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num >= Z.zero && den > Z.zero) then Ok (Q.make num den)\n else Error \"Invalid Reward Parameter: growth rate must be non-negative\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet adaptive_rewards_params_encoding =\n let open Data_encoding in\n conv\n (fun {\n issuance_ratio_final_min;\n issuance_ratio_final_max;\n issuance_ratio_initial_min;\n issuance_ratio_initial_max;\n initial_period;\n transition_period;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n } ->\n ( issuance_ratio_final_min,\n issuance_ratio_final_max,\n issuance_ratio_initial_min,\n issuance_ratio_initial_max,\n initial_period,\n transition_period,\n max_bonus,\n growth_rate,\n center_dz,\n radius_dz ))\n (fun ( issuance_ratio_final_min,\n issuance_ratio_final_max,\n issuance_ratio_initial_min,\n issuance_ratio_initial_max,\n initial_period,\n transition_period,\n max_bonus,\n growth_rate,\n center_dz,\n radius_dz ) ->\n {\n issuance_ratio_final_min;\n issuance_ratio_final_max;\n issuance_ratio_initial_min;\n issuance_ratio_initial_max;\n initial_period;\n transition_period;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n })\n (obj10\n (req \"issuance_ratio_final_min\" extremum_encoding)\n (req \"issuance_ratio_final_max\" extremum_encoding)\n (req \"issuance_ratio_initial_min\" extremum_encoding)\n (req \"issuance_ratio_initial_max\" extremum_encoding)\n (req \"initial_period\" uint8)\n (req \"transition_period\" uint8)\n (req \"max_bonus\" Issuance_bonus_repr.max_bonus_encoding)\n (req \"growth_rate\" growth_rate_encoding)\n (req \"center_dz\" center_encoding)\n (req \"radius_dz\" radius_encoding))\n\nlet adaptive_issuance_encoding =\n let open Data_encoding in\n conv\n (fun {\n global_limit_of_staking_over_baking;\n edge_of_staking_over_delegation;\n launch_ema_threshold;\n adaptive_rewards_params;\n activation_vote_enable;\n autostaking_enable;\n force_activation;\n ns_enable;\n } ->\n ( global_limit_of_staking_over_baking,\n edge_of_staking_over_delegation,\n launch_ema_threshold,\n adaptive_rewards_params,\n activation_vote_enable,\n autostaking_enable,\n force_activation,\n ns_enable ))\n (fun ( global_limit_of_staking_over_baking,\n edge_of_staking_over_delegation,\n launch_ema_threshold,\n adaptive_rewards_params,\n activation_vote_enable,\n autostaking_enable,\n force_activation,\n ns_enable ) ->\n {\n global_limit_of_staking_over_baking;\n edge_of_staking_over_delegation;\n launch_ema_threshold;\n adaptive_rewards_params;\n activation_vote_enable;\n autostaking_enable;\n force_activation;\n ns_enable;\n })\n (obj8\n (req \"global_limit_of_staking_over_baking\" uint8)\n (req \"edge_of_staking_over_delegation\" uint8)\n (req \"adaptive_issuance_launch_ema_threshold\" int32)\n (req \"adaptive_rewards_params\" adaptive_rewards_params_encoding)\n (req \"adaptive_issuance_activation_vote_enable\" bool)\n (req \"autostaking_enable\" bool)\n (req \"adaptive_issuance_force_activation\" bool)\n (req \"ns_enable\" bool))\n\nlet issuance_weights_encoding =\n let open Data_encoding in\n conv\n (fun ({\n base_total_issued_per_minute;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n } :\n issuance_weights) ->\n ( base_total_issued_per_minute,\n baking_reward_fixed_portion_weight,\n baking_reward_bonus_weight,\n attesting_reward_weight,\n seed_nonce_revelation_tip_weight,\n vdf_revelation_tip_weight ))\n (fun ( base_total_issued_per_minute,\n baking_reward_fixed_portion_weight,\n baking_reward_bonus_weight,\n attesting_reward_weight,\n seed_nonce_revelation_tip_weight,\n vdf_revelation_tip_weight ) ->\n {\n base_total_issued_per_minute;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n })\n (obj6\n (req \"base_total_issued_per_minute\" Tez_repr.encoding)\n (req \"baking_reward_fixed_portion_weight\" int31)\n (req \"baking_reward_bonus_weight\" int31)\n (req \"attesting_reward_weight\" int31)\n (req \"seed_nonce_revelation_tip_weight\" int31)\n (req \"vdf_revelation_tip_weight\" int31))\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun c ->\n ( ( ( c.consensus_rights_delay,\n c.blocks_preservation_cycles,\n c.delegate_parameters_activation_delay ),\n ( c.blocks_per_cycle,\n c.blocks_per_commitment,\n c.nonce_revelation_threshold,\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.minimal_frozen_stake,\n c.vdf_difficulty,\n c.origination_size,\n c.issuance_weights,\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.limit_of_delegation_over_baking,\n c.percentage_of_frozen_deposits_slashed_per_double_baking,\n c.percentage_of_frozen_deposits_slashed_per_double_attestation,\n c.max_slashing_per_block,\n c.max_slashing_threshold,\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.dal,\n ( (c.sc_rollup, c.zk_rollup),\n (c.adaptive_issuance, c.direct_ticket_spending_enable) ) )\n ) ) ) ) ))\n (fun ( ( ( consensus_rights_delay,\n blocks_preservation_cycles,\n delegate_parameters_activation_delay ),\n ( blocks_per_cycle,\n blocks_per_commitment,\n nonce_revelation_threshold,\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 ( ( minimal_frozen_stake,\n vdf_difficulty,\n origination_size,\n issuance_weights,\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 limit_of_delegation_over_baking,\n percentage_of_frozen_deposits_slashed_per_double_baking,\n percentage_of_frozen_deposits_slashed_per_double_attestation,\n max_slashing_per_block,\n max_slashing_threshold,\n testnet_dictator,\n initial_seed ),\n ( ( cache_script_size,\n cache_stake_distribution_cycles,\n cache_sampler_state_cycles ),\n ( dal,\n ( (sc_rollup, zk_rollup),\n (adaptive_issuance, direct_ticket_spending_enable) ) ) )\n ) ) ) ) ->\n {\n consensus_rights_delay;\n blocks_preservation_cycles;\n delegate_parameters_activation_delay;\n blocks_per_cycle;\n blocks_per_commitment;\n nonce_revelation_threshold;\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 minimal_frozen_stake;\n vdf_difficulty;\n origination_size;\n issuance_weights;\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 consensus_committee_size;\n consensus_threshold;\n limit_of_delegation_over_baking;\n percentage_of_frozen_deposits_slashed_per_double_baking;\n percentage_of_frozen_deposits_slashed_per_double_attestation;\n max_slashing_per_block;\n max_slashing_threshold;\n testnet_dictator;\n initial_seed;\n cache_script_size;\n cache_stake_distribution_cycles;\n cache_sampler_state_cycles;\n dal;\n sc_rollup;\n zk_rollup;\n adaptive_issuance;\n direct_ticket_spending_enable;\n })\n (merge_objs\n (merge_objs\n (obj3\n (req \"consensus_rights_delay\" uint8)\n (req \"blocks_preservation_cycles\" uint8)\n (req \"delegate_parameters_activation_delay\" uint8))\n (obj8\n (req \"blocks_per_cycle\" int32)\n (req \"blocks_per_commitment\" int32)\n (req \"nonce_revelation_threshold\" 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 (obj7\n (req \"minimal_frozen_stake\" Tez_repr.encoding)\n (req \"vdf_difficulty\" int64)\n (req \"origination_size\" int31)\n (req \"issuance_weights\" issuance_weights_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 (obj8\n (req \"minimal_participation_ratio\" Ratio_repr.encoding)\n (req \"limit_of_delegation_over_baking\" uint8)\n (req\n \"percentage_of_frozen_deposits_slashed_per_double_baking\"\n Percentage.encoding)\n (req\n \"percentage_of_frozen_deposits_slashed_per_double_attestation\"\n Percentage.encoding)\n (req \"max_slashing_per_block\" Percentage.encoding)\n (req \"max_slashing_threshold\" int31)\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 (obj1 (req \"dal_parametric\" dal_encoding))\n (merge_objs\n (merge_objs sc_rollup_encoding zk_rollup_encoding)\n (merge_objs\n adaptive_issuance_encoding\n (obj1 (req \"direct_ticket_spending_enable\" bool))))))))))\n\nlet update_sc_rollup_parameter ~block_time c =\n let seconds_in_a_day = 60 * 60 * 24 in\n let seconds_in_a_week = seconds_in_a_day * 7 in\n {\n c with\n challenge_window_in_blocks = seconds_in_a_week * 2 / block_time;\n (* Same as challenge_window_in_blocks *)\n max_active_outbox_levels = Int32.of_int (seconds_in_a_week * 2 / block_time);\n commitment_period_in_blocks = 60 * 15 / block_time;\n max_lookahead_in_blocks = Int32.of_int (seconds_in_a_day * 30 / block_time);\n timeout_period_in_blocks = seconds_in_a_week / block_time;\n }\n\nmodule Internal_for_tests = struct\n let sc_rollup_encoding = sc_rollup_encoding\nend\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 incentives_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n attestation_threshold : int;\n cryptobox_parameters : Dal.parameters;\n}\n\nval dal_encoding : dal Data_encoding.t\n\ntype sc_rollup_reveal_hashing_schemes = {blake2B : Raw_level_repr.t}\n\n(** Associates reveal kinds to their activation level. *)\ntype sc_rollup_reveal_activation_level = {\n raw_data : sc_rollup_reveal_hashing_schemes;\n metadata : Raw_level_repr.t;\n dal_page : Raw_level_repr.t;\n dal_parameters : Raw_level_repr.t;\n dal_attested_slots_validity_lag : int;\n}\n\ntype sc_rollup = {\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 (* Activation's block level of reveal kinds. *)\n reveal_activation_level : sc_rollup_reveal_activation_level;\n (* Activates an updatable whitelist of stakers. Only keys in the whitelist are\n allowed to stake and publish a commitment. *)\n private_enable : bool;\n (* Activates the RISC-V pvm. *)\n riscv_pvm_enable : bool;\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 max_ticket_payload_size : int;\n}\n\ntype adaptive_rewards_params = {\n issuance_ratio_final_min : (* Minimum yearly issuance rate *) Q.t;\n issuance_ratio_final_max : (* Maximum yearly issuance rate *) Q.t;\n issuance_ratio_initial_min :\n (* Minimum yearly issuance rate at adaptive issuance activation *) Q.t;\n issuance_ratio_initial_max :\n (* Maximum yearly issuance rate at adaptive issuance activation *) Q.t;\n initial_period :\n (* Period in cycles during which the minimum and maximum yearly\n issuance rate values stay at their initial values *)\n int;\n transition_period :\n (* Period in cycles during which the minimum and maximum yearly\n issuance rate values decrease/increase until they reach their global values *)\n int;\n max_bonus : (* Maximum issuance bonus value *) Issuance_bonus_repr.max_bonus;\n growth_rate : (* Bonus value's growth rate *) Q.t;\n center_dz : (* Center for bonus *) Q.t;\n radius_dz :\n (* Minimum distance from center required for non-zero growth *) Q.t;\n}\n\ntype adaptive_issuance = {\n global_limit_of_staking_over_baking\n (* Global maximum stake tokens taken into account per baking token. Each baker can set their own lower limit. *) :\n int;\n edge_of_staking_over_delegation :\n (* Weight of staking over delegation. *) int;\n launch_ema_threshold : (* Threshold of the activation vote *) int32;\n adaptive_rewards_params :\n (* Parameters for the reward mechanism *) adaptive_rewards_params;\n activation_vote_enable :\n (* If set to true, reaching the launch_ema_threshold in the adaptive\n issuance activation vote triggers the activation of the adaptive\n inflation feature; otherwise the activation vote has no effect. *)\n bool;\n autostaking_enable :\n (* If set to true, a stake/unstake/finalize operation will be triggered for\n all delegate at end of cycle. *)\n bool;\n force_activation :\n (* For testing purposes. If set to true, the adaptive issuance feature is\n enabled without waiting to reach the launch_ema_threshold.*)\n bool;\n ns_enable : (* If set to true, enables the NS feature *)\n bool;\n}\n\ntype issuance_weights = {\n (* [base_total_issued_per_minute] is the total amount of rewards expected to\n be distributed every minute *)\n base_total_issued_per_minute : Tez_repr.t;\n (* The following fields represent the \"weights\" of the respective reward kinds.\n The actual reward values are computed proportionally from the other weights\n as a portion of the [base_total_issued_per_minute]. See the module\n {!Delegate_rewards} for more details *)\n baking_reward_fixed_portion_weight : int;\n baking_reward_bonus_weight : int;\n attesting_reward_weight : int;\n seed_nonce_revelation_tip_weight : int;\n vdf_revelation_tip_weight : int;\n}\n\ntype t = {\n (* Number of cycles after which computed consensus rights are used to actually\n participate in the consensus *)\n consensus_rights_delay : int;\n (* Number of past cycles about which the protocol hints the shell that it should\n keep them in its history. *)\n blocks_preservation_cycles : int;\n (* Number of cycles after which submitted delegate parameters are being\n used. *)\n delegate_parameters_activation_delay : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : 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 minimal_frozen_stake : Tez_repr.t;\n vdf_difficulty : int64;\n origination_size : int;\n issuance_weights : issuance_weights;\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 limit_of_delegation_over_baking : int;\n (* upper bound on the (delegated tz / own frozen tz) ratio *)\n percentage_of_frozen_deposits_slashed_per_double_baking : Percentage.t;\n percentage_of_frozen_deposits_slashed_per_double_attestation : Percentage.t;\n max_slashing_per_block : Percentage.t;\n max_slashing_threshold : int;\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 dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n adaptive_issuance : adaptive_issuance;\n direct_ticket_spending_enable : bool;\n}\n\nval encoding : t Data_encoding.encoding\n\nval update_sc_rollup_parameter : block_time:int -> sc_rollup -> sc_rollup\n\nmodule Internal_for_tests : sig\n val sc_rollup_encoding : sc_rollup Data_encoding.t\nend\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 incentives_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n attestation_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 incentives_enable;\n number_of_slots;\n attestation_lag;\n attestation_threshold;\n cryptobox_parameters;\n } ->\n ( ( feature_enable,\n incentives_enable,\n number_of_slots,\n attestation_lag,\n attestation_threshold ),\n cryptobox_parameters ))\n (fun ( ( feature_enable,\n incentives_enable,\n number_of_slots,\n attestation_lag,\n attestation_threshold ),\n cryptobox_parameters ) ->\n {\n feature_enable;\n incentives_enable;\n number_of_slots;\n attestation_lag;\n attestation_threshold;\n cryptobox_parameters;\n })\n (merge_objs\n (obj5\n (req \"feature_enable\" bool)\n (req \"incentives_enable\" bool)\n (req \"number_of_slots\" uint16)\n (req \"attestation_lag\" uint8)\n (req \"attestation_threshold\" uint8))\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 sc_rollup_reveal_hashing_schemes = {blake2B : Raw_level_repr.t}\n\ntype sc_rollup_reveal_activation_level = {\n raw_data : sc_rollup_reveal_hashing_schemes;\n metadata : Raw_level_repr.t;\n dal_page : Raw_level_repr.t;\n dal_parameters : Raw_level_repr.t;\n (* Once a DAL slot is attested, a rollup can only import it within the range\n of levels [attested_level; attested_level +\n dal_attested_slots_validity_lag]. *)\n (* Warning: the semantics of valid slots needs to be adapted if the\n value of this parameter is changed in the future.\n - If it is increased, some attested slots that were outdated with\n the old value will become valid again.\n - If it is decreased, some attested slots that were valid with\n the old value will become outdated.\n\n In both cases, the status of slots before and after the value change is\n different. Said otherwise, the validity of the slot may differ depending on\n the time of the check, in particular it may be different in the following\n two cases: (a) the slot is imported before the value upgrade, (2) a\n refutation game targeting a page of that slot is started after the\n upgrade. *)\n dal_attested_slots_validity_lag : int;\n}\n\nlet sc_rollup_reveal_hashing_schemes_encoding =\n let open Data_encoding in\n conv\n (fun t -> t.blake2B)\n (fun blake2B -> {blake2B})\n (obj1 (req \"Blake2B\" Raw_level_repr.encoding))\n\nlet sc_rollup_reveal_activation_level_encoding :\n sc_rollup_reveal_activation_level Data_encoding.t =\n let open Data_encoding in\n conv\n (fun t ->\n ( t.raw_data,\n t.metadata,\n t.dal_page,\n t.dal_parameters,\n t.dal_attested_slots_validity_lag ))\n (fun ( raw_data,\n metadata,\n dal_page,\n dal_parameters,\n dal_attested_slots_validity_lag ) ->\n {\n raw_data;\n metadata;\n dal_page;\n dal_parameters;\n dal_attested_slots_validity_lag;\n })\n (obj5\n (req \"raw_data\" sc_rollup_reveal_hashing_schemes_encoding)\n (req \"metadata\" Raw_level_repr.encoding)\n (req \"dal_page\" Raw_level_repr.encoding)\n (req \"dal_parameters\" Raw_level_repr.encoding)\n (req \"dal_attested_slots_validity_lag\" Data_encoding.int31))\n\ntype sc_rollup = {\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 reveal_activation_level : sc_rollup_reveal_activation_level;\n private_enable : bool;\n riscv_pvm_enable : bool;\n}\n\ntype zk_rollup = {\n enable : bool;\n origination_size : int;\n min_pending_to_process : int;\n max_ticket_payload_size : int;\n}\n\ntype adaptive_rewards_params = {\n issuance_ratio_final_min : Q.t;\n issuance_ratio_final_max : Q.t;\n issuance_ratio_initial_min : Q.t;\n issuance_ratio_initial_max : Q.t;\n initial_period : int;\n transition_period : int;\n max_bonus : Issuance_bonus_repr.max_bonus;\n growth_rate : Q.t;\n center_dz : Q.t;\n radius_dz : Q.t;\n}\n\ntype adaptive_issuance = {\n global_limit_of_staking_over_baking : int;\n edge_of_staking_over_delegation : int;\n launch_ema_threshold : int32;\n adaptive_rewards_params : adaptive_rewards_params;\n activation_vote_enable : bool;\n autostaking_enable : bool;\n force_activation : bool;\n ns_enable : bool;\n}\n\ntype issuance_weights = {\n base_total_issued_per_minute : Tez_repr.t;\n baking_reward_fixed_portion_weight : int;\n baking_reward_bonus_weight : int;\n attesting_reward_weight : int;\n seed_nonce_revelation_tip_weight : int;\n vdf_revelation_tip_weight : int;\n}\n\ntype t = {\n consensus_rights_delay : int;\n blocks_preservation_cycles : int;\n delegate_parameters_activation_delay : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : 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 minimal_frozen_stake : Tez_repr.t;\n vdf_difficulty : int64;\n origination_size : int;\n issuance_weights : issuance_weights;\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 limit_of_delegation_over_baking : int;\n percentage_of_frozen_deposits_slashed_per_double_baking : Percentage.t;\n percentage_of_frozen_deposits_slashed_per_double_attestation : Percentage.t;\n max_slashing_per_block : Percentage.t;\n max_slashing_threshold : int;\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 dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n adaptive_issuance : adaptive_issuance;\n direct_ticket_spending_enable : bool;\n}\n\nlet sc_rollup_encoding =\n let open Data_encoding in\n conv\n (fun (c : sc_rollup) ->\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 c.reveal_activation_level,\n c.private_enable,\n c.riscv_pvm_enable ) ))\n (fun ( ( 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 sc_rollup_reveal_activation_level,\n sc_rollup_private_enable,\n sc_rollup_riscv_pvm_enable ) ) ->\n {\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 reveal_activation_level = sc_rollup_reveal_activation_level;\n private_enable = sc_rollup_private_enable;\n riscv_pvm_enable = sc_rollup_riscv_pvm_enable;\n })\n (merge_objs\n (obj8\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 (obj7\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 (req\n \"smart_rollup_reveal_activation_level\"\n sc_rollup_reveal_activation_level_encoding)\n (req \"smart_rollup_private_enable\" bool)\n (req \"smart_rollup_riscv_pvm_enable\" bool)))\n\nlet zk_rollup_encoding =\n let open Data_encoding in\n conv\n (fun ({\n enable;\n origination_size;\n min_pending_to_process;\n max_ticket_payload_size;\n } :\n zk_rollup) ->\n (enable, origination_size, min_pending_to_process, max_ticket_payload_size))\n (fun ( zk_rollup_enable,\n zk_rollup_origination_size,\n zk_rollup_min_pending_to_process,\n zk_rollup_max_ticket_payload_size ) ->\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 max_ticket_payload_size = zk_rollup_max_ticket_payload_size;\n })\n (obj4\n (req \"zk_rollup_enable\" bool)\n (req \"zk_rollup_origination_size\" int31)\n (req \"zk_rollup_min_pending_to_process\" int31)\n (req \"zk_rollup_max_ticket_payload_size\" int31))\n\nlet extremum_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num > Z.zero && den > Z.zero) then Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Extremum Parameter: only positive values allowed\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet center_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num >= Z.zero && den > Z.zero && num <= den) then\n Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Parameter: dead zone center can only be between 0 \\\n and 1\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet radius_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num >= Z.zero && den > Z.zero) then Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Parameter: dead zone radius must be non-negative\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet growth_rate_encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num >= Z.zero && den > Z.zero) then Ok (Q.make num den)\n else Error \"Invalid Reward Parameter: growth rate must be non-negative\")\n (obj2 (req \"numerator\" z) (req \"denominator\" z)))\n\nlet adaptive_rewards_params_encoding =\n let open Data_encoding in\n conv\n (fun {\n issuance_ratio_final_min;\n issuance_ratio_final_max;\n issuance_ratio_initial_min;\n issuance_ratio_initial_max;\n initial_period;\n transition_period;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n } ->\n ( issuance_ratio_final_min,\n issuance_ratio_final_max,\n issuance_ratio_initial_min,\n issuance_ratio_initial_max,\n initial_period,\n transition_period,\n max_bonus,\n growth_rate,\n center_dz,\n radius_dz ))\n (fun ( issuance_ratio_final_min,\n issuance_ratio_final_max,\n issuance_ratio_initial_min,\n issuance_ratio_initial_max,\n initial_period,\n transition_period,\n max_bonus,\n growth_rate,\n center_dz,\n radius_dz ) ->\n {\n issuance_ratio_final_min;\n issuance_ratio_final_max;\n issuance_ratio_initial_min;\n issuance_ratio_initial_max;\n initial_period;\n transition_period;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n })\n (obj10\n (req \"issuance_ratio_final_min\" extremum_encoding)\n (req \"issuance_ratio_final_max\" extremum_encoding)\n (req \"issuance_ratio_initial_min\" extremum_encoding)\n (req \"issuance_ratio_initial_max\" extremum_encoding)\n (req \"initial_period\" uint8)\n (req \"transition_period\" uint8)\n (req \"max_bonus\" Issuance_bonus_repr.max_bonus_encoding)\n (req \"growth_rate\" growth_rate_encoding)\n (req \"center_dz\" center_encoding)\n (req \"radius_dz\" radius_encoding))\n\nlet adaptive_issuance_encoding =\n let open Data_encoding in\n conv\n (fun {\n global_limit_of_staking_over_baking;\n edge_of_staking_over_delegation;\n launch_ema_threshold;\n adaptive_rewards_params;\n activation_vote_enable;\n autostaking_enable;\n force_activation;\n ns_enable;\n } ->\n ( global_limit_of_staking_over_baking,\n edge_of_staking_over_delegation,\n launch_ema_threshold,\n adaptive_rewards_params,\n activation_vote_enable,\n autostaking_enable,\n force_activation,\n ns_enable ))\n (fun ( global_limit_of_staking_over_baking,\n edge_of_staking_over_delegation,\n launch_ema_threshold,\n adaptive_rewards_params,\n activation_vote_enable,\n autostaking_enable,\n force_activation,\n ns_enable ) ->\n {\n global_limit_of_staking_over_baking;\n edge_of_staking_over_delegation;\n launch_ema_threshold;\n adaptive_rewards_params;\n activation_vote_enable;\n autostaking_enable;\n force_activation;\n ns_enable;\n })\n (obj8\n (req \"global_limit_of_staking_over_baking\" uint8)\n (req \"edge_of_staking_over_delegation\" uint8)\n (req \"adaptive_issuance_launch_ema_threshold\" int32)\n (req \"adaptive_rewards_params\" adaptive_rewards_params_encoding)\n (req \"adaptive_issuance_activation_vote_enable\" bool)\n (req \"autostaking_enable\" bool)\n (req \"adaptive_issuance_force_activation\" bool)\n (req \"ns_enable\" bool))\n\nlet issuance_weights_encoding =\n let open Data_encoding in\n conv\n (fun ({\n base_total_issued_per_minute;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n } :\n issuance_weights) ->\n ( base_total_issued_per_minute,\n baking_reward_fixed_portion_weight,\n baking_reward_bonus_weight,\n attesting_reward_weight,\n seed_nonce_revelation_tip_weight,\n vdf_revelation_tip_weight ))\n (fun ( base_total_issued_per_minute,\n baking_reward_fixed_portion_weight,\n baking_reward_bonus_weight,\n attesting_reward_weight,\n seed_nonce_revelation_tip_weight,\n vdf_revelation_tip_weight ) ->\n {\n base_total_issued_per_minute;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n })\n (obj6\n (req \"base_total_issued_per_minute\" Tez_repr.encoding)\n (req \"baking_reward_fixed_portion_weight\" int31)\n (req \"baking_reward_bonus_weight\" int31)\n (req \"attesting_reward_weight\" int31)\n (req \"seed_nonce_revelation_tip_weight\" int31)\n (req \"vdf_revelation_tip_weight\" int31))\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun c ->\n ( ( ( c.consensus_rights_delay,\n c.blocks_preservation_cycles,\n c.delegate_parameters_activation_delay ),\n ( c.blocks_per_cycle,\n c.blocks_per_commitment,\n c.nonce_revelation_threshold,\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.minimal_frozen_stake,\n c.vdf_difficulty,\n c.origination_size,\n c.issuance_weights,\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.limit_of_delegation_over_baking,\n c.percentage_of_frozen_deposits_slashed_per_double_baking,\n c.percentage_of_frozen_deposits_slashed_per_double_attestation,\n c.max_slashing_per_block,\n c.max_slashing_threshold,\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.dal,\n ( (c.sc_rollup, c.zk_rollup),\n (c.adaptive_issuance, c.direct_ticket_spending_enable) ) )\n ) ) ) ) ))\n (fun ( ( ( consensus_rights_delay,\n blocks_preservation_cycles,\n delegate_parameters_activation_delay ),\n ( blocks_per_cycle,\n blocks_per_commitment,\n nonce_revelation_threshold,\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 ( ( minimal_frozen_stake,\n vdf_difficulty,\n origination_size,\n issuance_weights,\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 limit_of_delegation_over_baking,\n percentage_of_frozen_deposits_slashed_per_double_baking,\n percentage_of_frozen_deposits_slashed_per_double_attestation,\n max_slashing_per_block,\n max_slashing_threshold,\n testnet_dictator,\n initial_seed ),\n ( ( cache_script_size,\n cache_stake_distribution_cycles,\n cache_sampler_state_cycles ),\n ( dal,\n ( (sc_rollup, zk_rollup),\n (adaptive_issuance, direct_ticket_spending_enable) ) ) )\n ) ) ) ) ->\n {\n consensus_rights_delay;\n blocks_preservation_cycles;\n delegate_parameters_activation_delay;\n blocks_per_cycle;\n blocks_per_commitment;\n nonce_revelation_threshold;\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 minimal_frozen_stake;\n vdf_difficulty;\n origination_size;\n issuance_weights;\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 consensus_committee_size;\n consensus_threshold;\n limit_of_delegation_over_baking;\n percentage_of_frozen_deposits_slashed_per_double_baking;\n percentage_of_frozen_deposits_slashed_per_double_attestation;\n max_slashing_per_block;\n max_slashing_threshold;\n testnet_dictator;\n initial_seed;\n cache_script_size;\n cache_stake_distribution_cycles;\n cache_sampler_state_cycles;\n dal;\n sc_rollup;\n zk_rollup;\n adaptive_issuance;\n direct_ticket_spending_enable;\n })\n (merge_objs\n (merge_objs\n (obj3\n (req \"consensus_rights_delay\" uint8)\n (req \"blocks_preservation_cycles\" uint8)\n (req \"delegate_parameters_activation_delay\" uint8))\n (obj8\n (req \"blocks_per_cycle\" int32)\n (req \"blocks_per_commitment\" int32)\n (req \"nonce_revelation_threshold\" 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 (obj7\n (req \"minimal_frozen_stake\" Tez_repr.encoding)\n (req \"vdf_difficulty\" int64)\n (req \"origination_size\" int31)\n (req \"issuance_weights\" issuance_weights_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 (obj8\n (req \"minimal_participation_ratio\" Ratio_repr.encoding)\n (req \"limit_of_delegation_over_baking\" uint8)\n (req\n \"percentage_of_frozen_deposits_slashed_per_double_baking\"\n Percentage.encoding)\n (req\n \"percentage_of_frozen_deposits_slashed_per_double_attestation\"\n Percentage.encoding)\n (req \"max_slashing_per_block\" Percentage.encoding)\n (req \"max_slashing_threshold\" int31)\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 (obj1 (req \"dal_parametric\" dal_encoding))\n (merge_objs\n (merge_objs sc_rollup_encoding zk_rollup_encoding)\n (merge_objs\n adaptive_issuance_encoding\n (obj1 (req \"direct_ticket_spending_enable\" bool))))))))))\n\nlet update_sc_rollup_parameter ~block_time c =\n let seconds_in_a_day = 60 * 60 * 24 in\n let seconds_in_a_week = seconds_in_a_day * 7 in\n {\n c with\n challenge_window_in_blocks = seconds_in_a_week * 2 / block_time;\n (* Same as challenge_window_in_blocks *)\n max_active_outbox_levels = Int32.of_int (seconds_in_a_week * 2 / block_time);\n commitment_period_in_blocks = 60 * 15 / block_time;\n max_lookahead_in_blocks = Int32.of_int (seconds_in_a_day * 30 / block_time);\n timeout_period_in_blocks = seconds_in_a_week / block_time;\n }\n\nmodule Internal_for_tests = struct\n let sc_rollup_encoding = sc_rollup_encoding\nend\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(*****************************************************************************)\nval version_value : string\n\nval version : string\n\nval mainnet_id : Chain_id.t\n\nval ghostnet_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(** The max slashing period is the maximum number of cycles after which a\n misbehaviour can be denounced, i.e. if a misbehaviour happened at cycle [c],\n it will be rejected if it is denounced at cycle [c + max_slashing_period].\n Having [max_slashing_period] strictly smaller than 2 doesn't make sense.\n Indeed, if a misbehaviour happens at the very last block of a cycle, it\n couldn't be denounced.\n [max_slashing_period = 2] leaves one cycle to denounce a misbehaviour in\n the worst case, which is deemed enough.\n Several parts of the codebase may use the fact that\n [max_slashing_period = 2], so let's ensure it cannot be different. *)\nval max_slashing_period : 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 issuance_weights : Constants_parametric_repr.issuance_weights;\n max_slashing_threshold : int;\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 : consensus_committee_size:int -> 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(*****************************************************************************)\nlet version_value = \"paris_020\"\n\nlet version = \"v1\"\n\nlet mainnet_id = Chain_id.of_b58check_exn \"NetXdQprcVkpaWU\"\n\nlet ghostnet_id = Chain_id.of_b58check_exn \"NetXnHfVqm9iesp\"\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\nlet max_slashing_period = 2\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 ( max_slashing_period,\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 ( _max_slashing_period,\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 (obj4\n (req \"max_slashing_period\" uint8)\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 Result_syntax in\n let open Constants_parametric_repr in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n (* The [limit_of_delegation_over_baking] should be non-negative. *)\n let* () =\n error_unless\n Compare.Int.(constants.limit_of_delegation_over_baking >= 0)\n (Invalid_protocol_constants\n \"The delegation over baking limit must be greater than or equal to 0.\")\n in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 in\n let* () =\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 \\\n greater than 0.\")\n in\n let* () =\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 in\n let* () =\n error_unless\n Compare.Int.(\n constants.dal.number_of_slots > 0\n && constants.dal.number_of_slots <= 256)\n (Invalid_protocol_constants\n \"The number of data availability slot must be between 1 and 256\")\n in\n let* () =\n error_unless\n Compare.Int.(constants.dal.attestation_lag > 1)\n (Invalid_protocol_constants\n \"The attestation_lag must be strictly greater than 1, because only \\\n slot headers in finalized blocks are attested.\")\n in\n let* () =\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 in\n Result.return_unit\n\nmodule Generated = struct\n type t = {\n consensus_threshold : int;\n issuance_weights : Constants_parametric_repr.issuance_weights;\n max_slashing_threshold : int;\n }\n\n let generate ~consensus_committee_size =\n (* The weights are expressed in [(256 * 80)]th of the total\n reward, because it is the smallest proportion used so far*)\n (* let f = consensus_committee_size / 3 in *)\n let max_slashing_threshold = (consensus_committee_size / 3) + 1 in\n let consensus_threshold = (consensus_committee_size * 2 / 3) + 1 in\n let bonus_committee_size = consensus_committee_size - consensus_threshold in\n let base_total_issued_per_minute = Tez_repr.of_mutez_exn 80_007_812L in\n let _reward_parts_whole = 20480 (* = 256 * 80 *) in\n let reward_parts_half = 10240 (* = reward_parts_whole / 2 *) in\n let reward_parts_quarter = 5120 (* = reward_parts_whole / 4 *) in\n {\n max_slashing_threshold;\n consensus_threshold;\n issuance_weights =\n {\n base_total_issued_per_minute;\n (* 80.007812 tez/minute *)\n baking_reward_fixed_portion_weight =\n (* 1/4 or 1/2 *)\n (if Compare.Int.(bonus_committee_size <= 0) then\n (* a fortiori, consensus_committee_size < 4 *)\n reward_parts_half\n else reward_parts_quarter);\n baking_reward_bonus_weight =\n (* 1/4 or 0 *)\n (if Compare.Int.(bonus_committee_size <= 0) then 0\n else reward_parts_quarter);\n attesting_reward_weight = reward_parts_half;\n (* 1/2 *)\n (* All block (baking + attesting)rewards sum to 1 ( *256*80 ) *)\n seed_nonce_revelation_tip_weight = 1;\n (* 1/20480 *)\n vdf_revelation_tip_weight = 1;\n (* 1/20480 *)\n };\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 = "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(** Returns the locked round from a raw fitness. If the fitness is\n from a previous version, the returned value will be None. *)\nval locked_round_from_raw : Fitness.t -> Round_repr.t option 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\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 let open Result_syntax 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 -> return {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 return {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 let open Result_syntax in\n match locked_round with\n | None -> return {level; locked_round; predecessor_round; round}\n | Some locked_round_val ->\n let* () =\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 in\n return {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 let open Result_syntax in\n if Compare.Int.(Bytes.length b <> 4) then tzfail Invalid_fitness\n else return (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 let open Result_syntax in\n match Bytes.length b with\n | 0 -> return_none\n | 4 ->\n let* r = Round_repr.of_int32 (TzEndian.get_int32 b 0) in\n return_some r\n | _ -> tzfail Invalid_fitness\n\nlet predecessor_round_of_bytes neg_predecessor_round =\n let open Result_syntax in\n let* neg_predecessor_round = int32_of_bytes neg_predecessor_round in\n Round_repr.of_int32 @@ Int32.pred (Int32.neg neg_predecessor_round)\n\nlet round_of_bytes round =\n let open Result_syntax in\n let* value = int32_of_bytes round in\n Round_repr.of_int32 value\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 =\n let open Result_syntax in\n 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 let* level =\n let* value = int32_of_bytes level in\n Raw_level_repr.of_int32 value\n in\n let* locked_round = locked_round_of_bytes locked_round in\n let* predecessor_round =\n predecessor_round_of_bytes neg_predecessor_round\n in\n let* round = round_of_bytes round in\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 tzfail Outdated_fitness\n | [] (* genesis fitness *) -> tzfail Outdated_fitness\n | _ -> tzfail Invalid_fitness\n\nlet round_from_raw =\n let open Result_syntax in\n 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 return Round_repr.zero\n | [] (* genesis fitness *) -> return Round_repr.zero\n | _ -> tzfail Invalid_fitness\n\nlet predecessor_round_from_raw =\n let open Result_syntax in\n 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 return Round_repr.zero\n | [] (* genesis fitness *) -> return Round_repr.zero\n | _ -> tzfail Invalid_fitness\n\nlet locked_round_from_raw =\n let open Result_syntax in\n 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 locked_round_of_bytes locked_round\n | [version; _]\n when Compare.String.(\n Bytes.to_string version < Constants_repr.fitness_version_number) ->\n return_none\n | [] (* former genesis fitness *) -> return_none\n | _ -> tzfail 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 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 = "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\n\n val root : 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 let open Result_syntax in\n match cycle_eras with\n | [] -> tzfail 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 tzfail Invalid_cycle_eras\n | [] -> return_unit\n in\n let* () = aux newest_era older_eras in\n return 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 open Result_syntax in\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+ () =\n error_when\n Raw_level_repr.(level < first_level_in_alpha_family)\n (Level_not_in_alpha 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\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 Result_syntax.tzfail\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 }\n\n let root =\n {\n level = Raw_level_repr.root;\n level_position = 0l;\n cycle = Cycle_repr.root;\n cycle_position = 0l;\n expected_commitment = false;\n }\nend\n" ;
} ;
{ name = "Script_repr_costs_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model encoding/DECODING_MICHELINE *)\n(* fun size1 ->\n fun size2 ->\n fun size3 -> max 10 (((60. * size1) + (10. * size2)) + (10. * size3)) *)\nlet cost_DECODING_MICHELINE size1 size2 size3 =\n S.max\n (S.safe_int 10)\n ((size1 * S.safe_int 60) + (size2 * S.safe_int 10) + (size3 * S.safe_int 10))\n\n(* model encoding/DECODING_MICHELINE_bytes *)\n(* fun size -> max 10 (20. * size) *)\nlet cost_DECODING_MICHELINE_bytes size =\n S.max (S.safe_int 10) (size * S.safe_int 20)\n\n(* model encoding/ENCODING_MICHELINE *)\n(* fun size1 ->\n fun size2 ->\n fun size3 -> max 10 (((100. * size1) + (25. * size2)) + (10. * size3)) *)\nlet cost_ENCODING_MICHELINE size1 size2 size3 =\n S.max\n (S.safe_int 10)\n ((size1 * S.safe_int 100)\n + (size2 * S.safe_int 25)\n + (size3 * S.safe_int 10))\n\n(* model encoding/ENCODING_MICHELINE_bytes *)\n(* fun size -> max 10 (33. * size) *)\nlet cost_ENCODING_MICHELINE_bytes size =\n S.max (S.safe_int 10) (size * S.safe_int 33)\n\n(* model micheline/strip_locations_micheline *)\n(* fun size -> max 10 (51. * size) *)\nlet cost_strip_locations_micheline size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 51)\n\n(* model script_repr/MICHELINE_NODES *)\n(* fun size -> max 10 (0. + (6.4928521501 * size)) *)\nlet cost_MICHELINE_NODES size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) ((size lsr 1) + (size * S.safe_int 6))\n\n(* model script_repr/strip_annotations *)\n(* fun size -> max 10 (51. * size) *)\nlet cost_strip_annotations size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 51)\n" ;
} ;
{ name = "Script_repr_costs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2023 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 Script_repr_costs_generated\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).\n\n let cost_strip_locations_micheline = cost_strip_locations_micheline\n*)\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).\n\n let cost_strip_annotations = cost_strip_annotations\n*)\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 {!type-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 {!type-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 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] []\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 ({nodes; string_bytes; z_bytes} : Micheline_size.t) =\n Script_repr_costs.cost_DECODING_MICHELINE nodes z_bytes string_bytes\n\n let bytes_dependent_cost = Script_repr_costs.cost_DECODING_MICHELINE_bytes\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 ({nodes; string_bytes; z_bytes} : Micheline_size.t) =\n Script_repr_costs.cost_ENCODING_MICHELINE nodes z_bytes string_bytes\n\n let bytes_dependent_cost = Script_repr_costs.cost_ENCODING_MICHELINE_bytes\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_encoding.micheline_size_dependent_cost size\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_decoding.micheline_size_dependent_cost size\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 @@ 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 @@ Micheline_encoding.bytes_dependent_cost (S.safe_int bytes_len)\n\nlet cost_micheline_strip_locations size =\n Gas_limit_repr.atomic_step_cost\n @@ Script_repr_costs.cost_strip_locations_micheline size\n\nlet cost_micheline_strip_annotations size =\n Gas_limit_repr.atomic_step_cost\n @@ Script_repr_costs.cost_strip_annotations size\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 let open Result_syntax in\n match Data_encoding.force_decode lexpr with\n | Some v -> return v\n | None -> tzfail 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 ( ++ ) (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(** A random seed, to derive random sequences from *)\ntype seed\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(** {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 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 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\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 let open Result_syntax in\n if Compare.Int.(Bytes.length nonce <> Constants_repr.nonce_length) then\n tzfail Unexpected_nonce_length\n else return 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 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_i\n (fun i (small, large) (_, p) ->\n let q = Mass.mul p n in\n if Mass.(q < total) then ((q, i) :: small, large)\n else (small, (q, i) :: large))\n ([], [])\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 {!type-Data_encoding.case}s used to define\n {!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 let open Result_syntax in\n match Base58.decode s with\n | Some data -> (\n match of_b58data data with\n | Some c -> return c\n | None -> tzfail (Invalid_contract_notation s))\n | None -> tzfail (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 _ ->\n Json.cannot_destruct \"Invalid contract notation %S.\" s)\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 {!type-value},\n you can use {!val-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 let open Result_syntax in\n fun i ->\n if Compare.Int32.(0l <= i) then return (Index i)\n else tzfail (Index_cannot_be_negative i)\n\nlet from_index : int32 -> 'a either tzresult =\n let open Result_syntax in\n fun i ->\n if Compare.Int32.(0l <= i) then return (Hidden_index i)\n else tzfail (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 -> match destruct v with Left _ -> Error error | Right v -> 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(** Entrypoint \"stake\" *)\nval stake : t\n\n(** Entrypoint \"unstake\" *)\nval unstake : t\n\n(** Entrypoint \"finalize_unstake\" *)\nval finalize_unstake : t\n\n(** Entrypoint \"set_delegate_parameters\" *)\nval set_delegate_parameters : 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 let open Result_syntax in\n match of_string str with\n | Too_long -> tzfail (Name_too_long str)\n | Got_default -> tzfail (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 let open Result_syntax in\n match of_non_empty_string a with\n | Too_long -> tzfail (Name_too_long (a :> string))\n | Got_default -> tzfail (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 -> Result_syntax.tzfail (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 -> Result_syntax.tzfail (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 stake = of_string_strict_exn \"stake\"\n\nlet unstake = of_string_strict_exn \"unstake\"\n\nlet finalize_unstake = of_string_strict_exn \"finalize_unstake\"\n\nlet set_delegate_parameters = of_string_strict_exn \"set_delegate_parameters\"\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 builtin_case 6 stake;\n builtin_case 7 unstake;\n builtin_case 8 finalize_unstake;\n builtin_case 9 set_delegate_parameters;\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_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\n(** {1 Slot index}\n\n A slot index is a possible value for a slot index with an upper\n bound. If a choice is ever made to increase the size of available\n slots in the protocol, we also need to change this module to\n accommodate for higher values. *)\ntype t\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\nval zero : t\n\ntype error += Invalid_slot_index of {given : t; min : t; max : t}\n\nval check_is_in_range : number_of_slots:int -> t -> unit tzresult\n\n(** [of_int ~number_of_slots n] constructs a value of type {!t} from [n]. Returns\n {!Invalid_slot_index} in case the given value is not in the interval\n [[zero, number_of_slots-1]]. *)\nval of_int : number_of_slots:int -> int -> t tzresult\n\n(** [of_int_opt ~number_of_slots n] constructs a value of type {!t} from [n]. Returns [None]\n in case the given value is not in the interval [[zero, number_of_slots-1]]. *)\nval of_int_opt : number_of_slots:int -> int -> t option\n\nval to_int : t -> int\n\nval to_int_list : t list -> int list\n\n(** [slots_range ~number_of_slots ~lower ~upper] returns the list of slots indexes between\n [lower] and [upper].\n\n If [lower] is negative or [upper] is bigger than or equal to [number_of_slots], the function\n returns {!Invalid_slot_index}. *)\nval slots_range :\n number_of_slots:int -> lower:int -> upper:int -> t list tzresult\n\n(** [slots_range_opt ~number_of_slots ~lower ~upper] is similar to {!slots_range}, but return\n [None] instead of an error. *)\nval slots_range_opt :\n number_of_slots:int -> lower:int -> upper:int -> t list option\n\n(** [is_succ elt ~succ] returns true if and only if elt + 1 = succ. *)\nval is_succ : t -> succ:t -> bool\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\ntype t = int\n\nlet encoding = Data_encoding.uint8\n\nlet pp = Format.pp_print_int\n\nlet zero = 0\n\ntype error += Invalid_slot_index of {given : int; min : int; max : int}\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"dal_slot_index_repr.index.invalid_index\"\n ~title:\"Invalid Dal slot index\"\n ~description:\"The given index is out of range of representable slot indices\"\n ~pp:(fun ppf (given, min, max) ->\n Format.fprintf\n ppf\n \"The given index %d is out of range of representable slot indices [%d, \\\n %d]\"\n given\n min\n max)\n (obj3 (req \"given\" int31) (req \"min\" int31) (req \"max\" int31))\n (function\n | Invalid_slot_index {given; min; max} -> Some (given, min, max)\n | _ -> None)\n (fun (given, min, max) -> Invalid_slot_index {given; min; max})\n\nlet check_is_in_range ~number_of_slots slot_index =\n error_unless\n Compare.Int.(slot_index >= zero && slot_index < number_of_slots)\n (Invalid_slot_index\n {given = slot_index; min = zero; max = number_of_slots - 1})\n\nlet of_int ~number_of_slots slot_index =\n let open Result_syntax in\n let* () = check_is_in_range ~number_of_slots slot_index in\n return slot_index\n\nlet of_int_opt ~number_of_slots slot_index =\n Option.of_result @@ of_int ~number_of_slots slot_index\n\nlet to_int slot_index = slot_index [@@ocaml.inline always]\n\nlet to_int_list l = l [@@ocaml.inline always]\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare = Compare.Int.compare\nend)\n\nlet slots_range ~number_of_slots ~lower ~upper =\n let open Result_syntax in\n let* () = check_is_in_range ~number_of_slots lower in\n let* () = check_is_in_range ~number_of_slots upper in\n return Misc.(lower --> upper)\n\nlet slots_range_opt ~number_of_slots ~lower ~upper =\n Option.of_result @@ slots_range ~number_of_slots ~lower ~upper\n\nlet is_succ t ~succ = Compare.Int.(t + 1 = succ)\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 {!Dal.Config.default}. *)\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\n\n (** Attempt to convert the input representing a commitment encoded as a b58\n string. *)\n val of_b58check_opt : string -> t option\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\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 : Dal_slot_index_repr.t}\n\n (** For Layer-1, a slot is described by its slot {!type-id} and the\n slot's commitment. *)\n type t = {id : id; commitment : Commitment.t}\n\n (** encoding for values of type {!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 (** pretty-printer for values of type {!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 (** [verify_commitment cryptobox commitment commitment_proof] check\n that for the given commitment, the commitment proof is correct\n using the [cryptbox] primitives. *)\n val verify_commitment :\n Dal.t -> Commitment.t -> Commitment_proof.t -> 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 = Dal_slot_index_repr.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\n type error += Invalid_page_index of {given : int; min : int; max : int}\n\n (** [is_in_range ~number_of_pages page_id] returns true if and only if the\n provided [page_id] is within the bounds of allowed pages. *)\n val check_is_in_range : number_of_pages:int -> int -> unit tzresult\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 {!History.t}) that\n represents a skip list used to store successive DAL slots confirmed/attested\n on L1. There is one slot per cell in the skip list. The slots are sorted in\n increasing order by level, and by slot index, for the slots of the same\n level.\n\n This module also defines a bounded history cache (type\n {!type-History.History_cache.t}) that allows to remember recent values of a\n skip list of type {!History.t} (indexed by the skip lists' hashes). This\n structure is meant to be maintained and used by the rollup node to produce\n refutation proofs involving DAL slot inputs.\n\n Note on terminology: \"confirmed slot\" is another name for \"attested slot\".\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 (** The genesis skip list that contains one dummy cell. This cell has\n {!Raw_level_repr.root} as published level and no attested slots. Since Dal\n is not necessarily activated in the genesis block (e.g. this will be the case\n on mainnet), the skip list is reset at the first call to\n {!add_confirmed_slot_headers} to enforce the invariant that there are no gaps\n in the levels of the cells of the skip list.\n\n So, a skip list is initialized with this genesis cell. It's then replaced\n with a growing (non-dummy) skip list as soon as a call to\n {!add_confirmed_slot_headers} with a level bigger than\n {!Raw_level_repr.root} is performed. This allows to activate Dal at any\n level and having a contiguous skip list (w.r.t. L1 levels). This\n representation allows to produce simpler proofs with a bounded history\n cache. *)\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 published_level ~number_of_slots\n slot_headers] updates the given structure [hist] with the list of\n [slot_headers]. The given [cache] is also updated to add successive values\n of [cell] to it.\n\n\n This function checks the following pre-conditions before updating the\n list:\n\n - The given [published_level] should match all the levels of the slots in\n [slot_headers], if any;\n\n - [published_level] is the successor the last inserted cell's level.\n\n - [slot_headers] is sorted in increasing order w.r.t. slots indices.\n *)\n val add_confirmed_slot_headers :\n t ->\n History_cache.t ->\n Raw_level_repr.t ->\n number_of_slots:int ->\n Header.t list ->\n (t * History_cache.t) tzresult\n\n (** Similiar to {!add_confirmed_slot_headers}, but no cache is provided or\n updated. *)\n val add_confirmed_slot_headers_no_cache :\n t -> Raw_level_repr.t -> number_of_slots:int -> 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 val pp : Format.formatter -> t -> unit\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 The function returns an error in case the slot is not confirmed but the\n page's content and proof are given. It also fails if the slot is confirmed\n but no or bad information about the page are provided.\n\n Note that, in case the level of the page is far in the past (the Dal skip\n list was not populated yet or the slots of the associated level are not\n valid anymore) should be handled by the caller.\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 (** The content of a cell in the DAL skip list. We don't store the slot\n headers directly to refactor the common [published_level] and save\n space. This is important for refutation proofs, as they have to fit in\n an L1 operation. *)\n type cell_content = Unattested of Header.id | Attested of Header.t\n\n (** Returns the content of the last cell in the given skip list. *)\n val content : t -> cell_content\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\n\n let of_b58check_opt = Dal.Commitment.of_b58check_opt\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 Header = struct\n type id = {published_level : Raw_level_repr.t; index : Dal_slot_index_repr.t}\n\n type t = {id : id; commitment : Commitment.t}\n\n let slot_id_equal {published_level; index} s2 =\n Raw_level_repr.equal published_level s2.published_level\n && Dal_slot_index_repr.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 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\" Dal_slot_index_repr.encoding))\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 (* A tag is added to ensure we can migrate from this encoding to\n different version if we decide to change the encoding. *)\n (union\n [\n case\n ~title:\"v0\"\n (Tag 0)\n (merge_objs\n (obj1 (req \"version\" (constant \"0\")))\n (merge_objs\n id_encoding\n (obj1 (req \"commitment\" Commitment.encoding))))\n (fun x -> Some ((), x))\n (fun ((), x) -> x);\n ])\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 Dal_slot_index_repr.pp\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 let verify_commitment cryptobox commitment proof =\n Ok (Dal.verify_commitment cryptobox commitment proof)\nend\n\nmodule Slot_index = Dal_slot_index_repr\n\nmodule Page = struct\n type content = Bytes.t\n\n type slot_index = Dal_slot_index_repr.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\n type error += Invalid_page_index of {given : int; min : int; max : int}\n\n let () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"dal_page_index_repr.index.invalid_index\"\n ~title:\"Invalid Dal page index\"\n ~description:\n \"The given index is out of range of representable page indices\"\n ~pp:(fun ppf (given, min, max) ->\n Format.fprintf\n ppf\n \"The given index %d is out of range of representable page indices \\\n [%d, %d]\"\n given\n min\n max)\n (obj3 (req \"given\" int31) (req \"min\" int31) (req \"max\" int31))\n (function\n | Invalid_page_index {given; min; max} -> Some (given, min, max)\n | _ -> None)\n (fun (given, min, max) -> Invalid_page_index {given; min; max})\n\n let check_is_in_range ~number_of_pages page_id =\n error_unless\n Compare.Int.(0 <= page_id && page_id < number_of_pages)\n (Invalid_page_index\n {given = page_id; min = zero; max = number_of_pages - 1})\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 (Dal_slot_index_repr)\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 <= Dal_slot_index_repr.to_int new_slot_header.id.index\n && Dal_slot_index_repr.to_int 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 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\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 Content = struct\n (** Each cell of the skip list is either a slot header that has been\n attested, or a published level and a slot index for which no slot header\n is attested (so, no associated commitment). *)\n type t = Unattested of Header.id | Attested of Header.t\n\n let content_id = function\n | Unattested slot_id -> slot_id\n | Attested {id; _} -> id\n\n let encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"unattested\"\n (Tag 0)\n (merge_objs\n (obj1 (req \"kind\" (constant \"unattested\")))\n Header.id_encoding)\n (function\n | Unattested slot_id -> Some ((), slot_id) | Attested _ -> None)\n (fun ((), slot_id) -> Unattested slot_id);\n case\n ~title:\"attested\"\n (Tag 1)\n (merge_objs\n (obj1 (req \"kind\" (constant \"attested\")))\n Header.encoding)\n (function\n | Unattested _ -> None\n | Attested slot_header -> Some ((), slot_header))\n (fun ((), slot_header) -> Attested slot_header);\n ]\n\n let equal t1 t2 =\n match (t1, t2) with\n | Unattested sid1, Unattested sid2 -> Header.slot_id_equal sid1 sid2\n | Attested sh1, Attested sh2 -> Header.equal sh1 sh2\n | Unattested _, _ | Attested _, _ -> false\n\n let zero, zero_level =\n let zero_level = Raw_level_repr.root in\n let zero_index = Dal_slot_index_repr.zero in\n (Unattested {published_level = zero_level; index = zero_index}, zero_level)\n\n let pp fmt = function\n | Unattested slot_id ->\n Format.fprintf fmt \"Unattested (%a)\" Header.pp_id slot_id\n | Attested slot_header ->\n Format.fprintf fmt \"Attested (%a)\" Header.pp slot_header\n end\n\n module Skip_list = struct\n include Skip_list.Make (Skip_list_parameters)\n\n (** All Dal slot indices for all levels will be stored in a skip list\n (with or without a commitment depending on attestation status of each\n slot), where only the last cell is needed to be remembered in the L1\n context. The skip list is used in the proof phase of a refutation game\n to verify whether a given slot is inserted as [Attested] or not in the\n skip list. The skip list is supposed to be sorted, as its 'search'\n function explicitly uses a given `compare` function during the list\n traversal to quickly (in log(size)) reach the target slot header id.\n Two cells compare in lexicographic ordering of their levels and slot indexes.\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 let next ~prev_cell ~prev_cell_ptr ~number_of_slots elt =\n let open Result_syntax in\n let well_ordered =\n (* For each cell we insert in the skip list, we ensure that it complies\n with the following invariant:\n - Either the published levels are successive (no gaps). In this case:\n * The last inserted slot's index for the previous level is\n [number_of_slots - 1];\n * The first inserted slot's index for the current level is 0\n - Or, levels are equal, but slot indices are successive. *)\n let Header.{published_level = l1; index = i1} =\n content prev_cell |> Content.content_id\n in\n let Header.{published_level = l2; index = i2} =\n Content.content_id elt\n in\n (Raw_level_repr.equal l2 (Raw_level_repr.succ l1)\n && Compare.Int.(Dal_slot_index_repr.to_int i1 = number_of_slots - 1)\n && Compare.Int.(Dal_slot_index_repr.to_int i2 = 0))\n || Raw_level_repr.equal l2 l1\n && Dal_slot_index_repr.is_succ i1 ~succ:i2\n in\n let* () =\n error_unless\n well_ordered\n Add_element_in_slots_skip_list_violates_ordering\n in\n return @@ next ~prev_cell ~prev_cell_ptr elt\n\n let search =\n let compare_with_slot_id (target_slot_id : Header.id)\n (content : Content.t) =\n let Header.{published_level = target_level; index = target_index} =\n target_slot_id\n in\n let Header.{published_level; index} = Content.content_id content in\n let c = Raw_level_repr.compare published_level target_level in\n if Compare.Int.(c <> 0) then c\n else Dal_slot_index_repr.compare index target_index\n in\n fun ~deref ~cell ~target_slot_id ->\n Lwt.search ~deref ~cell ~compare:(compare_with_slot_id target_slot_id)\n end\n\n module V1 = struct\n type content = Content.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 genesis, genesis_level =\n (Skip_list.genesis Content.zero, Content.zero_level)\n\n let history_encoding =\n let open Data_encoding in\n (* The history_encoding is given as a union of two versions of the skip\n list. The legacy case is only used to deserialize the skip list cells\n which may appear in refutation games started on a previous version of\n the protocol, before the activation of the DAL. In this case, the\n snapshotted cells are always the genesis one and cannot be used by the\n players so we deserialize it on the fly to the new representation of\n the genesis cell. *)\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"dal_skip_list_legacy\"\n (Tag 0)\n (obj2\n (req \"kind\" (constant \"dal_skip_list_legacy\"))\n (req \"skip_list\" (Data_encoding.Fixed.bytes Hex 57)))\n (fun _ -> None)\n (fun ((), _) -> genesis);\n case\n ~title:\"dal_skip_list\"\n (Tag 1)\n (obj2\n (req \"kind\" (constant \"dal_skip_list\"))\n (req\n \"skip_list\"\n (Skip_list.encoding Pointer_hash.encoding Content.encoding)))\n (fun x -> Some ((), x))\n (fun ((), x) -> x);\n ]\n\n let equal_history : history -> history -> bool =\n Skip_list.equal Pointer_hash.equal Content.equal\n\n let encoding = history_encoding\n\n let equal : t -> t -> bool = equal_history\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 Content.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:Content.pp ~pp_ptr:Pointer_hash.pp)\n history\n\n let pp = pp_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 (* Insert a cell in the skip list [t] and the corresponding association [(hash(t),\n t)] in the given [cache].\n\n Note that if the given skip list contains the genesis cell, its content is\n reset with the given content. This ensures the invariant that\n there are no gaps in the successive cells of the list. *)\n let add_cell (t, cache) next_cell_content ~number_of_slots =\n let open Result_syntax in\n let prev_cell_ptr = hash t in\n let Header.{published_level; _} =\n Skip_list.content t |> Content.content_id\n in\n let* new_head =\n if Raw_level_repr.equal published_level genesis_level then\n (* If this is the first real cell of DAL, replace dummy genesis. *)\n return (Skip_list.genesis next_cell_content)\n else\n Skip_list.next\n ~prev_cell:t\n ~prev_cell_ptr\n next_cell_content\n ~number_of_slots\n in\n let new_head_hash = hash new_head in\n let* cache = History_cache.remember new_head_hash new_head cache in\n return (new_head, cache)\n\n (* Given a list [attested_slot_headers] of well-ordered (wrt slots indices)\n (attested) slot headers, this function builds an extension [l] of\n [attested_slot_headers] such that:\n\n - all elements in [attested_slot_headers] are in [l],\n\n - for every slot index i in [0, number_of_slots - 1] that doesn't appear\n in [attested_slot_headers], an unattested slot id is inserted in [l],\n\n - [l] is well sorted wrt. slots indices. *)\n let fill_slot_headers ~number_of_slots ~published_level\n attested_slot_headers =\n let open Result_syntax in\n let module I = Dal_slot_index_repr in\n let* all_indices =\n I.slots_range ~number_of_slots ~lower:0 ~upper:(number_of_slots - 1)\n in\n let mk_unattested index =\n Content.Unattested Header.{published_level; index}\n in\n (* Hypothesis: both lists are sorted in increasing order w.r.t. slots\n indices. *)\n let rec aux indices slots =\n match (indices, slots) with\n | _, [] -> List.map mk_unattested indices |> ok\n | [], _s :: _ -> tzfail Add_element_in_slots_skip_list_violates_ordering\n | i :: indices', s :: slots' ->\n if I.(i = s.Header.id.index) then\n let* res = aux indices' slots' in\n Content.Attested s :: res |> ok\n else if I.(i < s.Header.id.index) then\n let* res = aux indices' slots in\n mk_unattested i :: res |> ok\n else\n (* i > s.Header.id.index *)\n tzfail Add_element_in_slots_skip_list_violates_ordering\n in\n aux all_indices attested_slot_headers\n\n (* Assuming a [number_of_slots] per L1 level, we will ensure below that we\n insert exactly [number_of_slots] cells in the skip list per level. This\n will simplify the shape of proofs and help bounding the history cache\n required for their generation. *)\n let add_confirmed_slot_headers (t : t) cache published_level\n ~number_of_slots attested_slot_headers =\n let open Result_syntax in\n let* () =\n List.iter_e\n (fun slot_header ->\n error_unless\n Raw_level_repr.(\n published_level = slot_header.Header.id.published_level)\n Add_element_in_slots_skip_list_violates_ordering)\n attested_slot_headers\n in\n let* slot_headers =\n fill_slot_headers\n ~number_of_slots\n ~published_level\n attested_slot_headers\n in\n List.fold_left_e (add_cell ~number_of_slots) (t, cache) slot_headers\n\n let add_confirmed_slot_headers_no_cache =\n let empty_cache = History_cache.empty ~capacity:0L in\n fun t published_level ~number_of_slots slots ->\n let open Result_syntax in\n let+ cell, (_ : History_cache.t) =\n add_confirmed_slot_headers\n t\n empty_cache\n published_level\n ~number_of_slots\n slots\n in\n cell\n\n (* Dal proofs section *)\n\n (** An inclusion proof is a sequence (list) of cells from the Dal skip list,\n represented as [c1; c2; ...; cn], that encodes a minimal path from the\n head [c1] (referred to as the \"reference\" or \"snapshot\" cell below) to a\n target cell [cn]. Thanks to the back-pointers, it can be demonstrated\n that the successive elements of the sequence are indeed cells of the\n skip list. *)\n type inclusion_proof = history list\n\n (** (See the documentation in the mli file to understand what we want to\n prove in a refutation game 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 attesters didn't\n confirm the availability of its data.\n\n To produce a proof representation for a page (see function\n {!produce_proof_repr} 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 - [get_history], a sufficiently large slots history cache, encoded as a\n function from pointer hashes to their corresponding skip lists cells, to\n navigate back through the successive cells of the skip list. The cache\n should at least contain the cells starting from the published level of\n the page ID for which we want to generate a proof. Indeed, inclusion\n proofs encode paths through skip lists' cells where the head is the\n reference/snapshot cell and the last element is the target cell inserted\n at the level corresponding to the page's published level). Note that, the\n case where the level of the page is far in the past (i.e. the skip list\n was not populated yet) should be handled by the caller ;\n\n - [page_info], provides information for [page_id]. In case the page is\n supposed to be confirmed, this argument should contain the page's\n content and the proof that the page is part of the (confirmed) slot\n whose ID is given in [page_id]. In case we want to show that the page is\n not confirmed, 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 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 {target_cell : history; inc_proof : inclusion_proof}\n (** The case where the slot's page doesn't exist or is not confirmed\n on L1. The fields are similar to {!Page_confirmed} case except\n that we don't have a page data or proof to check.\n\n As said above, in case the level of the page is far in the past\n (for instance, the skip list was not populated yet or the slots of\n that level are not valid to be imported by the DAL anymore) should\n be handled by the caller. In fact, the [proof_repr] type here only\n covers levels where a new cell has been added to the skip list. *)\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 (obj3\n (req \"kind\" (constant \"unconfirmed\"))\n (req \"target_cell\" history_encoding)\n (req \"inc_proof\" (list history_encoding)))\n (function\n | Page_unconfirmed {target_cell; inc_proof} ->\n Some ((), target_cell, inc_proof)\n | _ -> None)\n (fun ((), target_cell, inc_proof) ->\n Page_unconfirmed {target_cell; 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 let open Result_syntax in\n match Data_encoding.Binary.to_bytes_opt proof_repr_encoding proof with\n | None -> tzfail Dal_invalid_proof_serialization\n | Some serialized_proof -> return 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 let open Result_syntax in\n match Data_encoding.Binary.of_bytes_opt proof_repr_encoding proof with\n | None -> tzfail Dal_invalid_proof_deserialization\n | Some deserialized_proof -> return deserialized_proof\n\n let pp_inclusion_proof = Format.pp_print_list 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 {target_cell; inc_proof} ->\n Format.fprintf\n fmt\n \"Page_unconfirmed (target_cell = %a | inc_proof:[size=%d@ | \\\n path=%a])\"\n pp_history\n target_cell\n (List.length inc_proof)\n pp_inclusion_proof\n 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_unit\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 (** The [produce_proof_repr] function assumes that some invariants hold, such as:\n - The DAL has been activated,\n - The level of [page_id] is after the DAL activation level.\n\n Under these assumptions, we recall that we maintain an invariant\n ensuring that we a have a cell per slot index in the skip list at every level\n after DAL activation. *)\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 = target_slot_id; page_index = _} = page_id in\n (* We first search for the slots attested at level [published_level]. *)\n let*! search_result =\n Skip_list.search ~deref:get_history ~target_slot_id ~cell:slots_hist\n in\n (* The search should necessarily find a cell in the skip list (assuming\n enough cache is given) under the assumptions made when calling\n {!produce_proof_repr}. *)\n match 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 | Nearest _ ->\n (* This should not happen: there is one cell at each level\n after DAL activation. The case where the page's level is before DAL\n activation level should be handled by the caller\n ({!Sc_refutation_proof.produce} in our case). *)\n tzfail\n @@ dal_proof_error\n \"Skip_list.search returned Nearest', while all given levels to \\\n produce proofs are supposed to be in the skip list.\"\n | Found target_cell -> (\n let inc_proof = List.rev search_result.Skip_list.rev_path in\n match (page_info, Skip_list.content target_cell) with\n | Some (page_data, page_proof), Attested {commitment; id = _} ->\n (* The case where the slot to which the page is supposed to belong\n is found and the page's information are given. *)\n let*? () =\n (* We check the page's proof against the commitment. *)\n check_page_proof\n dal_params\n page_proof\n page_data\n page_id\n commitment\n in\n (* All checks succeeded. We return a `Page_confirmed` proof. *)\n return\n ( Page_confirmed {target_cell; inc_proof; page_data; page_proof},\n Some page_data )\n | None, Unattested _ ->\n (* The slot corresponding to the given page's index is not found in\n the attested slots of the page's level, and no information is\n given for that page. So, we produce a proof that the page is not\n attested. *)\n return (Page_unconfirmed {target_cell; inc_proof}, None)\n | None, Attested _ ->\n (* Mismatch: case where no page information are given, but the\n slot is attested. *)\n tzfail\n @@ dal_proof_error\n \"The page ID's slot is confirmed, but no page content and \\\n proof are provided.\"\n | Some _, Unattested _ ->\n (* Mismatch: case where page information are given, but the slot\n is not attested. *)\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 = Header.{published_level; index}; page_index = _} =\n page_id\n in\n let* target_cell, inc_proof, page_proof_check =\n match proof with\n | Page_confirmed {target_cell; inc_proof; page_data; page_proof} ->\n let page_proof_check =\n Some\n (fun commitment ->\n (* We check that the page indeed belongs to the target slot at the\n given page index. *)\n let* () =\n check_page_proof\n dal_params\n page_proof\n page_data\n page_id\n commitment\n in\n (* If the check succeeds, we return the data/content of the\n page. *)\n return page_data)\n in\n return (target_cell, inc_proof, page_proof_check)\n | Page_unconfirmed {target_cell; inc_proof} ->\n return (target_cell, inc_proof, None)\n in\n let cell_content = Skip_list.content target_cell in\n (* We check that the target cell has the same level and index than the\n page we're about to prove. *)\n let cell_id = Content.content_id cell_content in\n let* () =\n error_when\n Raw_level_repr.(cell_id.published_level <> published_level)\n (dal_proof_error \"verify_proof_repr: published_level mismatch.\")\n in\n let* () =\n error_when\n (not (Dal_slot_index_repr.equal cell_id.index index))\n (dal_proof_error \"verify_proof_repr: slot index mismatch.\")\n in\n (* We check that the given inclusion proof indeed links our L1 snapshot to\n the target cell. *)\n let* () =\n verify_inclusion_proof inc_proof ~src:snapshot ~dest:target_cell\n in\n match (page_proof_check, cell_content) with\n | None, Unattested _ -> return_none\n | Some page_proof_check, Attested {commitment; _} ->\n let* page_data = page_proof_check commitment in\n return_some page_data\n | Some _, Unattested _ ->\n error\n @@ dal_proof_error\n \"verify_proof_repr: the unconfirmation proof contains the \\\n target slot.\"\n | None, Attested _ ->\n error\n @@ dal_proof_error\n \"verify_proof_repr: the confirmation proof doesn't contain the \\\n attested slot.\"\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 type cell_content = Content.t =\n | Unattested of Header.id\n | Attested of Header.t\n\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 attesters in this\n context, can attest on the availability of the data via\n attestation operations.\n\n The slot is uniformly split into shards. Each attester 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 attestation operations. To avoid\n overloading the network, this representation should be compact. *)\n\ntype t = private Bitset.t\n\n(** The size of the encoding is not bounded. However, the size of a DAL\n attestation bitset is checked during validation of an attestation; and there\n is a bound on the size of a generic operation. *)\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_index_repr.t -> bool\n\n(** [commit slot_attestation index] commits into [slot_attestation]\n that the slot [index] is available. *)\nval commit : t -> Dal_slot_index_repr.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_index_repr.t -> int\n\n(** [number_of_attested_slots slot_attestation] returns the number of attested\n slots in an attestation. *)\nval number_of_attested_slots : 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 shard attestations.\n\n For each attester, 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 type attested_slots = t\n\n (** The data-structure used to record the shards attestations. *)\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_attested] accordingly. *)\n\n (** [init ~number_of_slots] initialises a new accountability data-structure\n with [number_of_slots] slots and where for every slot, no shard is\n available. *)\n val init : number_of_slots:int -> t\n\n (** [record_number_of_attested_shards t slots number] records that, for all\n slots declared available in [slots], the given [number] of shard indices\n are deemed available. This function must be called at most once for a\n given attester; otherwise the count will be flawed. *)\n val record_number_of_attested_shards : t -> attested_slots -> int -> t\n\n (** [is_slot_attested t ~threshold ~number_of_shards slot] returns [true] if\n the number of shards recorded in [t] for the [slot] is above the\n [threshold] with respect to the total number of shards specified by\n [number_of_shards]. Returns [false] otherwise or if the [index] is out of\n the interval [0; number_of_slots - 1] where [number_of_slots] is the value\n provided to the [init] function. *)\n val is_slot_attested :\n t -> threshold:int -> number_of_shards:int -> Dal_slot_index_repr.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. *)\n\n(* A set of (attested) slot indexes. *)\ntype t = Bitset.t\n\nlet encoding = Bitset.encoding\n\nlet empty = Bitset.empty\n\nlet is_attested t index =\n let open Dal_slot_index_repr 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_index_repr 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_index_repr 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\nlet number_of_attested_slots = Bitset.hamming_weight\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 type attested_slots = t\n\n module SlotMap = Map.Make (Compare.Int)\n\n type t = {number_of_attested_shards : int SlotMap.t; number_of_slots : int}\n\n let init ~number_of_slots =\n {number_of_attested_shards = SlotMap.empty; number_of_slots}\n\n (* This function must be called at most once for a given attester; otherwise\n the count will be flawed. *)\n let record_number_of_attested_shards t baker_attested_slots\n number_of_baker_shards =\n let rec iter slot_index map =\n if Compare.Int.(slot_index >= t.number_of_slots) then map\n else\n let map =\n match Bitset.mem baker_attested_slots slot_index with\n | Error _ ->\n (* impossible, as [slot_index] is non-negative *)\n map\n | Ok true ->\n (* slot is attested by baker *)\n SlotMap.update\n slot_index\n (function\n | None -> Some number_of_baker_shards\n | Some old_number_of_attested_shards ->\n Some\n (old_number_of_attested_shards + number_of_baker_shards))\n map\n | Ok false ->\n (* slot is not attested by baker, nothing to update *)\n map\n in\n iter (slot_index + 1) map\n in\n let number_of_attested_shards = iter 0 t.number_of_attested_shards in\n {t with number_of_attested_shards}\n\n let is_slot_attested t ~threshold ~number_of_shards slot_index =\n let index = Dal_slot_index_repr.to_int slot_index in\n let number_of_attested_shards =\n match SlotMap.find index t.number_of_attested_shards with\n | None -> 0\n | Some v -> v\n in\n Compare.Int.(\n number_of_attested_shards >= threshold * number_of_shards / 100)\nend\n" ;
} ;
{ name = "Michelson_v1_gas_costs_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model encoding/B58CHECK_DECODING_CHAIN_ID *)\n(* max 10 1600. *)\nlet cost_B58CHECK_DECODING_CHAIN_ID = S.safe_int 1600\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_HASH_bls *)\n(* max 10 3600. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_bls = S.safe_int 3600\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 *)\n(* max 10 3300. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 3300\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_HASH_p256 *)\n(* max 10 3300. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_p256 = S.safe_int 3300\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 *)\n(* max 10 3300. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 3300\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_bls *)\n(* max 10 79000. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_bls = S.safe_int 79000\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_ed25519 *)\n(* max 10 4200. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_ed25519 = S.safe_int 4200\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_p256 *)\n(* max 10 13450. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_p256 = S.safe_int 13450\n\n(* model encoding/B58CHECK_DECODING_PUBLIC_KEY_secp256k1 *)\n(* max 10 9000. *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_secp256k1 = S.safe_int 9000\n\n(* model encoding/B58CHECK_DECODING_SIGNATURE_bls *)\n(* max 10 6400. *)\nlet cost_B58CHECK_DECODING_SIGNATURE_bls = S.safe_int 6400\n\n(* model encoding/B58CHECK_DECODING_SIGNATURE_ed25519 *)\n(* max 10 6400. *)\nlet cost_B58CHECK_DECODING_SIGNATURE_ed25519 = S.safe_int 6400\n\n(* model encoding/B58CHECK_DECODING_SIGNATURE_p256 *)\n(* max 10 6400. *)\nlet cost_B58CHECK_DECODING_SIGNATURE_p256 = S.safe_int 6400\n\n(* model encoding/B58CHECK_DECODING_SIGNATURE_secp256k1 *)\n(* max 10 6400. *)\nlet cost_B58CHECK_DECODING_SIGNATURE_secp256k1 = S.safe_int 6400\n\n(* model encoding/B58CHECK_ENCODING_CHAIN_ID *)\n(* max 10 1800. *)\nlet cost_B58CHECK_ENCODING_CHAIN_ID = S.safe_int 1800\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_HASH_bls *)\n(* max 10 3200. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_bls = S.safe_int 3200\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 *)\n(* max 10 3200. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 3200\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256 *)\n(* max 10 3200. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256 = S.safe_int 3200\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 *)\n(* max 10 3200. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 3200\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_bls *)\n(* max 10 5900. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_bls = S.safe_int 5900\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_ed25519 *)\n(* max 10 4500. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_ed25519 = S.safe_int 4500\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_p256 *)\n(* max 10 4550. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_p256 = S.safe_int 4550\n\n(* model encoding/B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 *)\n(* max 10 4950. *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 = S.safe_int 4950\n\n(* model encoding/B58CHECK_ENCODING_SIGNATURE_bls *)\n(* max 10 8300. *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_bls = S.safe_int 8300\n\n(* model encoding/B58CHECK_ENCODING_SIGNATURE_ed25519 *)\n(* max 10 8300. *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_ed25519 = S.safe_int 8300\n\n(* model encoding/B58CHECK_ENCODING_SIGNATURE_p256 *)\n(* max 10 8300. *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_p256 = S.safe_int 8300\n\n(* model encoding/B58CHECK_ENCODING_SIGNATURE_secp256k1 *)\n(* max 10 8300. *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_secp256k1 = S.safe_int 8300\n\n(* model encoding/BLS_FR_FROM_Z *)\n(* max 10 178.443333333 *)\nlet cost_BLS_FR_FROM_Z = S.safe_int 180\n\n(* model encoding/BLS_FR_TO_Z *)\n(* max 10 82.8933333333 *)\nlet cost_BLS_FR_TO_Z = S.safe_int 85\n\n(* model encoding/CHECK_PRINTABLE *)\n(* fun size -> max 10 (14. + (10. * size)) *)\nlet cost_CHECK_PRINTABLE size =\n let size = S.safe_int size in\n (size * S.safe_int 10) + S.safe_int 15\n\n(* model encoding/DECODING_BLS_FR *)\n(* max 10 120. *)\nlet cost_DECODING_BLS_FR = S.safe_int 120\n\n(* model encoding/DECODING_BLS_G1 *)\n(* max 10 54600. *)\nlet cost_DECODING_BLS_G1 = S.safe_int 54600\n\n(* model encoding/DECODING_BLS_G2 *)\n(* max 10 69000. *)\nlet cost_DECODING_BLS_G2 = S.safe_int 69000\n\n(* model encoding/DECODING_CHAIN_ID *)\n(* max 10 50. *)\nlet cost_DECODING_CHAIN_ID = S.safe_int 50\n\n(* model encoding/DECODING_Chest *)\n(* fun size -> max 10 (3750. + (0.03125 * size)) *)\nlet cost_DECODING_Chest size =\n let size = S.safe_int size in\n (size lsr 5) + S.safe_int 3750\n\n(* model encoding/DECODING_Chest_key *)\n(* max 10 9550. *)\nlet cost_DECODING_Chest_key = S.safe_int 9550\n\n(* model encoding/DECODING_PUBLIC_KEY_HASH_bls *)\n(* max 10 60. *)\nlet cost_DECODING_PUBLIC_KEY_HASH_bls = S.safe_int 60\n\n(* model encoding/DECODING_PUBLIC_KEY_HASH_ed25519 *)\n(* max 10 60. *)\nlet cost_DECODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 60\n\n(* model encoding/DECODING_PUBLIC_KEY_HASH_p256 *)\n(* max 10 60. *)\nlet cost_DECODING_PUBLIC_KEY_HASH_p256 = S.safe_int 60\n\n(* model encoding/DECODING_PUBLIC_KEY_HASH_secp256k1 *)\n(* max 10 60. *)\nlet cost_DECODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 60\n\n(* model encoding/DECODING_PUBLIC_KEY_bls *)\n(* max 10 74000. *)\nlet cost_DECODING_PUBLIC_KEY_bls = S.safe_int 74000\n\n(* model encoding/DECODING_PUBLIC_KEY_ed25519 *)\n(* max 10 60. *)\nlet cost_DECODING_PUBLIC_KEY_ed25519 = S.safe_int 60\n\n(* model encoding/DECODING_PUBLIC_KEY_p256 *)\n(* max 10 9550. *)\nlet cost_DECODING_PUBLIC_KEY_p256 = S.safe_int 9550\n\n(* model encoding/DECODING_PUBLIC_KEY_secp256k1 *)\n(* max 10 4900. *)\nlet cost_DECODING_PUBLIC_KEY_secp256k1 = S.safe_int 4900\n\n(* model encoding/DECODING_SIGNATURE_bls *)\n(* max 10 40. *)\nlet cost_DECODING_SIGNATURE_bls = S.safe_int 40\n\n(* model encoding/DECODING_SIGNATURE_ed25519 *)\n(* max 10 35. *)\nlet cost_DECODING_SIGNATURE_ed25519 = S.safe_int 35\n\n(* model encoding/DECODING_SIGNATURE_p256 *)\n(* max 10 35. *)\nlet cost_DECODING_SIGNATURE_p256 = S.safe_int 35\n\n(* model encoding/DECODING_SIGNATURE_secp256k1 *)\n(* max 10 35. *)\nlet cost_DECODING_SIGNATURE_secp256k1 = S.safe_int 35\n\n(* model encoding/ENCODING_BLS_FR *)\n(* max 10 80. *)\nlet cost_ENCODING_BLS_FR = S.safe_int 80\n\n(* model encoding/ENCODING_BLS_G1 *)\n(* max 10 3200. *)\nlet cost_ENCODING_BLS_G1 = S.safe_int 3200\n\n(* model encoding/ENCODING_BLS_G2 *)\n(* max 10 3900. *)\nlet cost_ENCODING_BLS_G2 = S.safe_int 3900\n\n(* model encoding/ENCODING_CHAIN_ID *)\n(* max 10 50. *)\nlet cost_ENCODING_CHAIN_ID = S.safe_int 50\n\n(* model encoding/ENCODING_Chest *)\n(* fun size -> max 10 (6250. + (0.09375 * size)) *)\nlet cost_ENCODING_Chest size =\n let size = S.safe_int size in\n (size lsr 4) + (size lsr 5) + S.safe_int 6250\n\n(* model encoding/ENCODING_Chest_key *)\n(* max 10 15900. *)\nlet cost_ENCODING_Chest_key = S.safe_int 15900\n\n(* model encoding/ENCODING_PUBLIC_KEY_HASH_bls *)\n(* max 10 80. *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_bls = S.safe_int 80\n\n(* model encoding/ENCODING_PUBLIC_KEY_HASH_ed25519 *)\n(* max 10 70. *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 70\n\n(* model encoding/ENCODING_PUBLIC_KEY_HASH_p256 *)\n(* max 10 70. *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_p256 = S.safe_int 70\n\n(* model encoding/ENCODING_PUBLIC_KEY_HASH_secp256k1 *)\n(* max 10 70. *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 70\n\n(* model encoding/ENCODING_PUBLIC_KEY_bls *)\n(* max 10 90. *)\nlet cost_ENCODING_PUBLIC_KEY_bls = S.safe_int 90\n\n(* model encoding/ENCODING_PUBLIC_KEY_ed25519 *)\n(* max 10 80. *)\nlet cost_ENCODING_PUBLIC_KEY_ed25519 = S.safe_int 80\n\n(* model encoding/ENCODING_PUBLIC_KEY_p256 *)\n(* max 10 90. *)\nlet cost_ENCODING_PUBLIC_KEY_p256 = S.safe_int 90\n\n(* model encoding/ENCODING_PUBLIC_KEY_secp256k1 *)\n(* max 10 455. *)\nlet cost_ENCODING_PUBLIC_KEY_secp256k1 = S.safe_int 455\n\n(* model encoding/ENCODING_SIGNATURE_bls *)\n(* max 10 55. *)\nlet cost_ENCODING_SIGNATURE_bls = S.safe_int 55\n\n(* model encoding/ENCODING_SIGNATURE_ed25519 *)\n(* max 10 45. *)\nlet cost_ENCODING_SIGNATURE_ed25519 = S.safe_int 45\n\n(* model encoding/ENCODING_SIGNATURE_p256 *)\n(* max 10 45. *)\nlet cost_ENCODING_SIGNATURE_p256 = S.safe_int 45\n\n(* model encoding/ENCODING_SIGNATURE_secp256k1 *)\n(* max 10 45. *)\nlet cost_ENCODING_SIGNATURE_secp256k1 = S.safe_int 45\n\n(* model encoding/TIMESTAMP_READABLE_DECODING *)\n(* fun size -> max 10 (105. + (0.046875 * (size * (sqrt size)))) *)\nlet cost_TIMESTAMP_READABLE_DECODING size =\n let size = S.safe_int size in\n let w2 = sqrt size * size in\n (w2 lsr 5) + (w2 lsr 6) + S.safe_int 105\n\n(* model encoding/TIMESTAMP_READABLE_ENCODING *)\n(* max 10 820. *)\nlet cost_TIMESTAMP_READABLE_ENCODING = S.safe_int 820\n\n(* model interpreter/N_IAbs_int *)\n(* fun size -> max 10 (20. + (0.5 * size)) *)\nlet cost_N_IAbs_int size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 20\n\n(* model interpreter/N_IAbs_int_alloc *)\n(* fun size -> max 10 (14.9523489645 + (0.50021084529 * size)) *)\nlet cost_N_IAbs_int_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 15\n\n(* model interpreter/N_IAbs_int_synthesized *)\n(* fun size ->\n let time = 20. + (0.5 * size) in\n let alloc = 14.9523489645 + (0.50021084529 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IAbs_int_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 20) (w1 + (size lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_IAdd_bls12_381_fr *)\n(* max 10 30. *)\nlet cost_N_IAdd_bls12_381_fr = S.safe_int 30\n\n(* model interpreter/N_IAdd_bls12_381_fr_alloc *)\n(* max 10 24. *)\nlet cost_N_IAdd_bls12_381_fr_alloc = S.safe_int 25\n\n(* model interpreter/N_IAdd_bls12_381_fr_synthesized *)\n(* let time = 30. in let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_IAdd_bls12_381_fr_synthesized = S.safe_int 30\n\n(* model interpreter/N_IAdd_bls12_381_g1 *)\n(* max 10 900. *)\nlet cost_N_IAdd_bls12_381_g1 = S.safe_int 900\n\n(* model interpreter/N_IAdd_bls12_381_g1_alloc *)\n(* max 10 80. *)\nlet cost_N_IAdd_bls12_381_g1_alloc = S.safe_int 80\n\n(* model interpreter/N_IAdd_bls12_381_g1_synthesized *)\n(* let time = 900. in let alloc = 80. in max 10 (max time alloc) *)\nlet cost_N_IAdd_bls12_381_g1_synthesized = S.safe_int 900\n\n(* model interpreter/N_IAdd_bls12_381_g2 *)\n(* max 10 2470. *)\nlet cost_N_IAdd_bls12_381_g2 = S.safe_int 2470\n\n(* model interpreter/N_IAdd_bls12_381_g2_alloc *)\n(* max 10 152. *)\nlet cost_N_IAdd_bls12_381_g2_alloc = S.safe_int 155\n\n(* model interpreter/N_IAdd_bls12_381_g2_synthesized *)\n(* let time = 2470. in let alloc = 152. in max 10 (max time alloc) *)\nlet cost_N_IAdd_bls12_381_g2_synthesized = S.safe_int 2470\n\n(* model interpreter/N_IAdd_int *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IAdd_int size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAdd_int_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (16.6371367954 + (0.500211859928 * (max size1 size2))) *)\nlet cost_N_IAdd_int_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IAdd_int_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 16.6371367954 + (0.500211859928 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IAdd_int_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IAdd_nat *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IAdd_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAdd_nat_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (17.7896408261 + (0.500239743224 * (max size1 size2))) *)\nlet cost_N_IAdd_nat_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IAdd_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 17.7896408261 + (0.500239743224 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IAdd_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IAdd_seconds_to_timestamp *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IAdd_seconds_to_timestamp size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAdd_seconds_to_timestamp_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (16.6371367954 + (0.500211859928 * (max size1 size2))) *)\nlet cost_N_IAdd_seconds_to_timestamp_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IAdd_seconds_to_timestamp_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 16.6371367954 + (0.500211859928 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IAdd_seconds_to_timestamp_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IAdd_tez *)\n(* max 10 20. *)\nlet cost_N_IAdd_tez = S.safe_int 20\n\n(* model interpreter/N_IAdd_tez_alloc *)\n(* max 10 12. *)\nlet cost_N_IAdd_tez_alloc = S.safe_int 15\n\n(* model interpreter/N_IAdd_tez_synthesized *)\n(* let time = 20. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IAdd_tez_synthesized = S.safe_int 20\n\n(* model interpreter/N_IAdd_timestamp_to_seconds *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IAdd_timestamp_to_seconds size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAdd_timestamp_to_seconds_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (16.6371367954 + (0.500211859928 * (max size1 size2))) *)\nlet cost_N_IAdd_timestamp_to_seconds_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IAdd_timestamp_to_seconds_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 16.6371367954 + (0.500211859928 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IAdd_timestamp_to_seconds_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IAddress *)\n(* max 10 10. *)\nlet cost_N_IAddress = S.safe_int 10\n\n(* model interpreter/N_IAddress_alloc *)\n(* max 10 28. *)\nlet cost_N_IAddress_alloc = S.safe_int 30\n\n(* model interpreter/N_IAddress_synthesized *)\n(* let time = 10. in let alloc = 28. in max 10 (max time alloc) *)\nlet cost_N_IAddress_synthesized = S.safe_int 30\n\n(* model interpreter/N_IAmount *)\n(* max 10 10. *)\nlet cost_N_IAmount = S.safe_int 10\n\n(* model interpreter/N_IAmount_alloc *)\n(* max 10 12. *)\nlet cost_N_IAmount_alloc = S.safe_int 15\n\n(* model interpreter/N_IAmount_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IAmount_synthesized = S.safe_int 15\n\n(* model interpreter/N_IAnd *)\n(* max 10 10. *)\nlet cost_N_IAnd = S.safe_int 10\n\n(* model interpreter/N_IAnd_alloc *)\n(* max 10 0. *)\nlet cost_N_IAnd_alloc = S.safe_int 10\n\n(* model interpreter/N_IAnd_bytes *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (min size1 size2))) *)\nlet cost_N_IAnd_bytes size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.min size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAnd_bytes_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (11.02845262 + (0.499972333803 * (min size1 size2))) *)\nlet cost_N_IAnd_bytes_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.min size1 size2 lsr 1) + S.safe_int 15\n\n(* model interpreter/N_IAnd_bytes_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (min size1 size2)) in\n let alloc = 11.02845262 + (0.499972333803 * (min size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IAnd_bytes_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.min size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAnd_int_nat *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (min size1 size2))) *)\nlet cost_N_IAnd_int_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.min size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAnd_int_nat_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (15.9658045767 + (0.500213721396 * size2)) *)\nlet cost_N_IAnd_int_nat_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n (size2 lsr 1) + (size2 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IAnd_int_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (min size1 size2)) in\n let alloc = 15.9658045767 + (0.500213721396 * size2) in\n max 10 (max time alloc) *)\nlet cost_N_IAnd_int_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n S.max\n ((S.min size1 size2 lsr 1) + S.safe_int 35)\n ((size2 lsr 1) + (size2 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IAnd_nat *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (min size1 size2))) *)\nlet cost_N_IAnd_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.min size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IAnd_nat_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (15.929319772 + (0.50029450095 * (min size1 size2))) *)\nlet cost_N_IAnd_nat_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.min size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IAnd_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (min size1 size2)) in\n let alloc = 15.929319772 + (0.50029450095 * (min size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IAnd_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.min size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IAnd_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IAnd_synthesized = S.safe_int 10\n\n(* model interpreter/N_IApply_alloc *)\n(* fun size -> max 10 (if size = 0 then 225.986577181 else 510.013245033) *)\nlet cost_N_IApply_alloc size =\n let size = S.safe_int size in\n S.max\n (S.safe_int 10)\n (if size = S.safe_int 0 then S.safe_int 230 else S.safe_int 510)\n\n(* model interpreter/N_IApply_synthesized *)\n(* fun size ->\n let time = if size = 0 then 140. else 220. in\n let alloc = if size = 0 then 225.986577181 else 510.013245033 in\n max 10 (max time alloc) *)\nlet cost_N_IApply_synthesized size =\n let size = S.safe_int size in\n let w1 = size = S.safe_int 0 in\n S.max\n (S.max (S.safe_int 10) (if w1 then S.safe_int 140 else S.safe_int 220))\n (if w1 then S.safe_int 230 else S.safe_int 510)\n\n(* model interpreter/N_IBalance *)\n(* max 10 10. *)\nlet cost_N_IBalance = S.safe_int 10\n\n(* model interpreter/N_IBalance_alloc *)\n(* max 10 12. *)\nlet cost_N_IBalance_alloc = S.safe_int 15\n\n(* model interpreter/N_IBalance_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IBalance_synthesized = S.safe_int 15\n\n(* model interpreter/N_IBig_map_get *)\n(* fun size1 ->\n fun size2 ->\n max 10\n (822.930542675 + (2.84341564432 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IBig_map_get size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 * S.safe_int 2) + (w3 lsr 1) + (w3 lsr 2) + (w3 lsr 3) + S.safe_int 825\n\n(* model interpreter/N_IBig_map_get_alloc *)\n(* fun size1 -> fun size2 -> max 10 0. *)\nlet cost_N_IBig_map_get_alloc _size1 _size2 = S.safe_int 10\n\n(* model interpreter/N_IBig_map_get_and_update *)\n(* fun size1 ->\n fun size2 ->\n max 10\n (834.633876008 + (2.84264684858 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IBig_map_get_and_update size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 * S.safe_int 2) + (w3 lsr 1) + (w3 lsr 2) + (w3 lsr 3) + S.safe_int 835\n\n(* model interpreter/N_IBig_map_get_and_update_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((25.084669453 * (log2 (1 + size2))) + 178.035218425) *)\nlet cost_N_IBig_map_get_and_update_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n (w1 * S.safe_int 25) + (w1 lsr 1) + S.safe_int 180\n\n(* model interpreter/N_IBig_map_get_and_update_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n 834.633876008 + (2.84264684858 * (size1 * (log2 (1 + size2)))) in\n let alloc = (25.084669453 * (log2 (1 + size2))) + 178.035218425 in\n max 10 (max time alloc) *)\nlet cost_N_IBig_map_get_and_update_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n let w3 = w1 * size1 in\n S.max\n ((w3 * S.safe_int 2) + (w3 lsr 1) + (w3 lsr 2) + (w3 lsr 3) + S.safe_int 835)\n ((w1 * S.safe_int 25) + (w1 lsr 1) + S.safe_int 180)\n\n(* model interpreter/N_IBig_map_get_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n 822.930542675 + (2.84341564432 * (size1 * (log2 (1 + size2)))) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IBig_map_get_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 * S.safe_int 2) + (w3 lsr 1) + (w3 lsr 2) + (w3 lsr 3) + S.safe_int 825\n\n(* model interpreter/N_IBig_map_mem *)\n(* fun size1 ->\n fun size2 ->\n max 10 (824.703876008 + (2.8436528598 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IBig_map_mem size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 * S.safe_int 2) + (w3 lsr 1) + (w3 lsr 2) + (w3 lsr 3) + S.safe_int 825\n\n(* model interpreter/N_IBig_map_mem_alloc *)\n(* fun size1 -> fun size2 -> max 10 0. *)\nlet cost_N_IBig_map_mem_alloc _size1 _size2 = S.safe_int 10\n\n(* model interpreter/N_IBig_map_mem_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n 824.703876008 + (2.8436528598 * (size1 * (log2 (1 + size2)))) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IBig_map_mem_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 * S.safe_int 2) + (w3 lsr 1) + (w3 lsr 2) + (w3 lsr 3) + S.safe_int 825\n\n(* model interpreter/N_IBig_map_update *)\n(* fun size1 ->\n fun size2 ->\n max 10\n (816.020542675 + (3.16181279998 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IBig_map_update size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 * S.safe_int 3) + (w3 lsr 3) + (w3 lsr 4) + S.safe_int 820\n\n(* model interpreter/N_IBig_map_update_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((25.084669453 * (log2 (1 + size2))) + 166.035218425) *)\nlet cost_N_IBig_map_update_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n (w1 * S.safe_int 25) + (w1 lsr 1) + S.safe_int 170\n\n(* model interpreter/N_IBig_map_update_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n 816.020542675 + (3.16181279998 * (size1 * (log2 (1 + size2)))) in\n let alloc = (25.084669453 * (log2 (1 + size2))) + 166.035218425 in\n max 10 (max time alloc) *)\nlet cost_N_IBig_map_update_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n let w3 = w1 * size1 in\n S.max\n ((w3 * S.safe_int 3) + (w3 lsr 3) + (w3 lsr 4) + S.safe_int 820)\n ((w1 * S.safe_int 25) + (w1 lsr 1) + S.safe_int 170)\n\n(* model interpreter/N_IBlake2b *)\n(* fun size -> max 10 (430. + (1.125 * size)) *)\nlet cost_N_IBlake2b size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 430\n\n(* model interpreter/N_IBlake2b_alloc *)\n(* fun size -> max 10 24. *)\nlet cost_N_IBlake2b_alloc _size = S.safe_int 25\n\n(* model interpreter/N_IBlake2b_synthesized *)\n(* fun size ->\n let time = 430. + (1.125 * size) in\n let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_IBlake2b_synthesized size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 430\n\n(* model interpreter/N_IBytes_int *)\n(* fun size -> max 10 (90. + (3. * size)) *)\nlet cost_N_IBytes_int size =\n let size = S.safe_int size in\n (size * S.safe_int 3) + S.safe_int 90\n\n(* model interpreter/N_IBytes_int_alloc *)\n(* fun size -> max 10 (10.3902313247 + (0.499502439767 * size)) *)\nlet cost_N_IBytes_int_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 10\n\n(* model interpreter/N_IBytes_int_synthesized *)\n(* fun size ->\n let time = 90. + (3. * size) in\n let alloc = 10.3902313247 + (0.499502439767 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IBytes_int_synthesized size =\n let size = S.safe_int size in\n S.max ((size * S.safe_int 3) + S.safe_int 90) ((size lsr 1) + S.safe_int 10)\n\n(* model interpreter/N_IBytes_nat *)\n(* fun size -> max 10 (75. + (3. * size)) *)\nlet cost_N_IBytes_nat size =\n let size = S.safe_int size in\n (size * S.safe_int 3) + S.safe_int 75\n\n(* model interpreter/N_IBytes_nat_alloc *)\n(* fun size -> max 10 (10.7311846492 + (0.499435286092 * size)) *)\nlet cost_N_IBytes_nat_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 15\n\n(* model interpreter/N_IBytes_nat_synthesized *)\n(* fun size ->\n let time = 75. + (3. * size) in\n let alloc = 10.7311846492 + (0.499435286092 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IBytes_nat_synthesized size =\n let size = S.safe_int size in\n S.max ((size * S.safe_int 3) + S.safe_int 75) ((size lsr 1) + S.safe_int 15)\n\n(* model interpreter/N_IBytes_size *)\n(* max 10 10. *)\nlet cost_N_IBytes_size = S.safe_int 10\n\n(* model interpreter/N_IBytes_size_alloc *)\n(* max 10 0. *)\nlet cost_N_IBytes_size_alloc = S.safe_int 10\n\n(* model interpreter/N_IBytes_size_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IBytes_size_synthesized = S.safe_int 10\n\n(* model interpreter/N_ICar *)\n(* max 10 10. *)\nlet cost_N_ICar = S.safe_int 10\n\n(* model interpreter/N_ICar_alloc *)\n(* max 10 0. *)\nlet cost_N_ICar_alloc = S.safe_int 10\n\n(* model interpreter/N_ICar_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICar_synthesized = S.safe_int 10\n\n(* model interpreter/N_ICdr *)\n(* max 10 10. *)\nlet cost_N_ICdr = S.safe_int 10\n\n(* model interpreter/N_ICdr_alloc *)\n(* max 10 0. *)\nlet cost_N_ICdr_alloc = S.safe_int 10\n\n(* model interpreter/N_ICdr_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICdr_synthesized = S.safe_int 10\n\n(* model interpreter/N_IChainId *)\n(* max 10 15. *)\nlet cost_N_IChainId = S.safe_int 15\n\n(* model interpreter/N_IChainId_alloc *)\n(* max 10 20. *)\nlet cost_N_IChainId_alloc = S.safe_int 20\n\n(* model interpreter/N_IChainId_synthesized *)\n(* let time = 15. in let alloc = 20. in max 10 (max time alloc) *)\nlet cost_N_IChainId_synthesized = S.safe_int 20\n\n(* model interpreter/N_ICheck_signature_bls *)\n(* fun size -> max 10 (1570000. + (3. * size)) *)\nlet cost_N_ICheck_signature_bls size =\n let size = S.safe_int size in\n (size * S.safe_int 3) + S.safe_int 1570000\n\n(* model interpreter/N_ICheck_signature_bls_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_ICheck_signature_bls_alloc _size = S.safe_int 10\n\n(* model interpreter/N_ICheck_signature_bls_synthesized *)\n(* fun size ->\n let time = 1570000. + (3. * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICheck_signature_bls_synthesized size =\n let size = S.safe_int size in\n (size * S.safe_int 3) + S.safe_int 1570000\n\n(* model interpreter/N_ICheck_signature_ed25519 *)\n(* fun size -> max 10 (65800. + (1.125 * size)) *)\nlet cost_N_ICheck_signature_ed25519 size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 65800\n\n(* model interpreter/N_ICheck_signature_ed25519_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_ICheck_signature_ed25519_alloc _size = S.safe_int 10\n\n(* model interpreter/N_ICheck_signature_ed25519_synthesized *)\n(* fun size ->\n let time = 65800. + (1.125 * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICheck_signature_ed25519_synthesized size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 65800\n\n(* model interpreter/N_ICheck_signature_p256 *)\n(* fun size -> max 10 (341000. + (1.125 * size)) *)\nlet cost_N_ICheck_signature_p256 size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 341000\n\n(* model interpreter/N_ICheck_signature_p256_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_ICheck_signature_p256_alloc _size = S.safe_int 10\n\n(* model interpreter/N_ICheck_signature_p256_synthesized *)\n(* fun size ->\n let time = 341000. + (1.125 * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICheck_signature_p256_synthesized size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 341000\n\n(* model interpreter/N_ICheck_signature_secp256k1 *)\n(* fun size -> max 10 (51600. + (1.125 * size)) *)\nlet cost_N_ICheck_signature_secp256k1 size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 51600\n\n(* model interpreter/N_ICheck_signature_secp256k1_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_ICheck_signature_secp256k1_alloc _size = S.safe_int 10\n\n(* model interpreter/N_ICheck_signature_secp256k1_synthesized *)\n(* fun size ->\n let time = 51600. + (1.125 * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICheck_signature_secp256k1_synthesized size =\n let size = S.safe_int size in\n (size lsr 3) + size + S.safe_int 51600\n\n(* model interpreter/N_IComb *)\n(* fun size -> max 10 (40. + (3.25 * (sub size 2))) *)\nlet cost_N_IComb size =\n let size = S.safe_int size in\n let w1 = S.sub size (S.safe_int 2) in\n (w1 * S.safe_int 3) + (w1 lsr 2) + S.safe_int 40\n\n(* model interpreter/N_IComb_alloc *)\n(* fun size -> max 10 (5.60949553813 + (11.9823552149 * size)) *)\nlet cost_N_IComb_alloc size =\n let size = S.safe_int size in\n (size * S.safe_int 12) + S.safe_int 10\n\n(* model interpreter/N_IComb_get *)\n(* fun size -> max 10 (20. + (0.5625 * size)) *)\nlet cost_N_IComb_get size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 4) + S.safe_int 20\n\n(* model interpreter/N_IComb_get_alloc *)\n(* fun size -> max 10 (0. + (0. * size)) *)\nlet cost_N_IComb_get_alloc _size = S.safe_int 10\n\n(* model interpreter/N_IComb_get_synthesized *)\n(* fun size ->\n let time = 20. + (0.5625 * size) in\n let alloc = 0. + (0. * size) in max 10 (max time alloc) *)\nlet cost_N_IComb_get_synthesized size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 4) + S.safe_int 20\n\n(* model interpreter/N_IComb_set *)\n(* fun size -> max 10 (30. + (1.28125 * size)) *)\nlet cost_N_IComb_set size =\n let size = S.safe_int size in\n (size lsr 2) + (size lsr 5) + size + S.safe_int 30\n\n(* model interpreter/N_IComb_set_alloc *)\n(* fun size -> max 10 (5.97947366264 + (6.00684211245 * size)) *)\nlet cost_N_IComb_set_alloc size =\n let size = S.safe_int size in\n (size lsr 3) + (size * S.safe_int 6) + S.safe_int 10\n\n(* model interpreter/N_IComb_set_synthesized *)\n(* fun size ->\n let time = 30. + (1.28125 * size) in\n let alloc = 5.97947366264 + (6.00684211245 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IComb_set_synthesized size =\n let size = S.safe_int size in\n S.max\n ((size lsr 2) + (size lsr 5) + size + S.safe_int 30)\n ((size lsr 3) + (size * S.safe_int 6) + S.safe_int 10)\n\n(* model interpreter/N_IComb_synthesized *)\n(* fun size ->\n let time = 40. + (3.25 * (sub size 2)) in\n let alloc = 5.60949553813 + (11.9823552149 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IComb_synthesized size =\n let size = S.safe_int size in\n let w1 = S.sub size (S.safe_int 2) in\n S.max\n ((w1 * S.safe_int 3) + (w1 lsr 2) + S.safe_int 40)\n ((size * S.safe_int 12) + S.safe_int 10)\n\n(* model interpreter/N_ICompare *)\n(* fun size1 ->\n fun size2 -> max 10 (35. + (0.0234375 * (sub (min size1 size2) 1))) *)\nlet cost_N_ICompare size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub (S.min size1 size2) (S.safe_int 1) in\n (w1 lsr 6) + (w1 lsr 7) + S.safe_int 35\n\n(* model interpreter/N_ICompare_alloc *)\n(* fun size1 -> fun size2 -> max 10 0. *)\nlet cost_N_ICompare_alloc _size1 _size2 = S.safe_int 10\n\n(* model interpreter/N_ICompare_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.0234375 * (sub (min size1 size2) 1)) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ICompare_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub (S.min size1 size2) (S.safe_int 1) in\n (w1 lsr 6) + (w1 lsr 7) + S.safe_int 35\n\n(* model interpreter/N_IConcat_bytes_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((8.00002622858 + (0. * size1)) + (0.499999999744 * size2)) *)\nlet cost_N_IConcat_bytes_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n (size2 lsr 1) + S.safe_int 10\n\n(* model interpreter/N_IConcat_bytes_pair *)\n(* fun size1 -> fun size2 -> max 10 (45. + (0.5 * (size1 + size2))) *)\nlet cost_N_IConcat_bytes_pair size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n ((size1 + size2) lsr 1) + S.safe_int 45\n\n(* model interpreter/N_IConcat_bytes_pair_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (8.00048828125 + (0.499999761581 * (size1 + size2))) *)\nlet cost_N_IConcat_bytes_pair_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n ((size1 + size2) lsr 1) + S.safe_int 10\n\n(* model interpreter/N_IConcat_bytes_pair_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 45. + (0.5 * (size1 + size2)) in\n let alloc = 8.00048828125 + (0.499999761581 * (size1 + size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IConcat_bytes_pair_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n ((size1 + size2) lsr 1) + S.safe_int 45\n\n(* model interpreter/N_IConcat_bytes_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = (31.0272093413 + (0. * size1)) + (0.0853190494597 * size2) in\n let alloc = (8.00002622858 + (0. * size1)) + (0.499999999744 * size2) in\n max 10 (max time alloc) *)\nlet cost_N_IConcat_bytes_synthesized _size1 size2 =\n let size2 = S.safe_int size2 in\n S.max\n ((size2 lsr 4) + (size2 lsr 6) + (size2 lsr 7) + S.safe_int 35)\n ((size2 lsr 1) + S.safe_int 10)\n\n(* model interpreter/N_IConcat_string_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((6.82629751442 + (0. * size1)) + (0.500114619383 * size2)) *)\nlet cost_N_IConcat_string_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n (size2 lsr 1) + (size2 lsr 6) + S.safe_int 10\n\n(* model interpreter/N_IConcat_string_pair *)\n(* fun size1 -> fun size2 -> max 10 (45. + (0.5 * (size1 + size2))) *)\nlet cost_N_IConcat_string_pair size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n ((size1 + size2) lsr 1) + S.safe_int 45\n\n(* model interpreter/N_IConcat_string_pair_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (8.00048828125 + (0.499999761581 * (size1 + size2))) *)\nlet cost_N_IConcat_string_pair_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n ((size1 + size2) lsr 1) + S.safe_int 10\n\n(* model interpreter/N_IConcat_string_pair_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 45. + (0.5 * (size1 + size2)) in\n let alloc = 8.00048828125 + (0.499999761581 * (size1 + size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IConcat_string_pair_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n ((size1 + size2) lsr 1) + S.safe_int 45\n\n(* model interpreter/N_IConcat_string_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = (33.8372093413 + (0. * size1)) + (0.089723875507 * size2) in\n let alloc = (6.82629751442 + (0. * size1)) + (0.500114619383 * size2) in\n max 10 (max time alloc) *)\nlet cost_N_IConcat_string_synthesized _size1 size2 =\n let size2 = S.safe_int size2 in\n let w1 = size2 lsr 6 in\n S.max\n ((size2 lsr 4) + w1 + (size2 lsr 7) + (size2 lsr 8) + S.safe_int 35)\n ((size2 lsr 1) + w1 + S.safe_int 10)\n\n(* model interpreter/N_ICons_list *)\n(* max 10 10. *)\nlet cost_N_ICons_list = S.safe_int 10\n\n(* model interpreter/N_ICons_list_alloc *)\n(* max 10 24. *)\nlet cost_N_ICons_list_alloc = S.safe_int 25\n\n(* model interpreter/N_ICons_list_synthesized *)\n(* let time = 10. in let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_ICons_list_synthesized = S.safe_int 25\n\n(* model interpreter/N_ICons_none *)\n(* max 10 10. *)\nlet cost_N_ICons_none = S.safe_int 10\n\n(* model interpreter/N_ICons_none_alloc *)\n(* max 10 12. *)\nlet cost_N_ICons_none_alloc = S.safe_int 15\n\n(* model interpreter/N_ICons_none_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_ICons_none_synthesized = S.safe_int 15\n\n(* model interpreter/N_ICons_pair *)\n(* max 10 10. *)\nlet cost_N_ICons_pair = S.safe_int 10\n\n(* model interpreter/N_ICons_pair_alloc *)\n(* max 10 12. *)\nlet cost_N_ICons_pair_alloc = S.safe_int 15\n\n(* model interpreter/N_ICons_pair_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_ICons_pair_synthesized = S.safe_int 15\n\n(* model interpreter/N_ICons_some *)\n(* max 10 10. *)\nlet cost_N_ICons_some = S.safe_int 10\n\n(* model interpreter/N_ICons_some_alloc *)\n(* max 10 8. *)\nlet cost_N_ICons_some_alloc = S.safe_int 10\n\n(* model interpreter/N_ICons_some_synthesized *)\n(* let time = 10. in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_ICons_some_synthesized = S.safe_int 10\n\n(* model interpreter/N_IContract_alloc *)\n(* max 10 16. *)\nlet cost_N_IContract_alloc = S.safe_int 20\n\n(* model interpreter/N_IContract_synthesized *)\n(* let time = 30. in let alloc = 16. in max 10 (max time alloc) *)\nlet cost_N_IContract_synthesized = S.safe_int 30\n\n(* model interpreter/N_ICreate_contract_alloc *)\n(* max 10 196. *)\nlet cost_N_ICreate_contract_alloc = S.safe_int 200\n\n(* model interpreter/N_ICreate_contract_synthesized *)\n(* let time = 60. in let alloc = 196. in max 10 (max time alloc) *)\nlet cost_N_ICreate_contract_synthesized = S.safe_int 200\n\n(* model interpreter/N_IDiff_timestamps *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IDiff_timestamps size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IDiff_timestamps_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (17.5501373306 + (0.500211925836 * (max size1 size2))) *)\nlet cost_N_IDiff_timestamps_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IDiff_timestamps_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 17.5501373306 + (0.500211925836 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IDiff_timestamps_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IDig *)\n(* fun size -> max 10 (30. + (6.75 * size)) *)\nlet cost_N_IDig size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 2) + (size * S.safe_int 6) + S.safe_int 30\n\n(* model interpreter/N_IDig_alloc *)\n(* fun size -> max 10 (11.9761359318 + (12.005966017 * size)) *)\nlet cost_N_IDig_alloc size =\n let size = S.safe_int size in\n (size lsr 2) + (size * S.safe_int 12) + S.safe_int 15\n\n(* model interpreter/N_IDig_synthesized *)\n(* fun size ->\n let time = 30. + (6.75 * size) in\n let alloc = 11.9761359318 + (12.005966017 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IDig_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 2 in\n S.max\n ((size lsr 1) + w1 + (size * S.safe_int 6) + S.safe_int 30)\n (w1 + (size * S.safe_int 12) + S.safe_int 15)\n\n(* model interpreter/N_IDip *)\n(* max 10 10. *)\nlet cost_N_IDip = S.safe_int 10\n\n(* model interpreter/N_IDipN *)\n(* fun size -> max 10 (15. + (4. * size)) *)\nlet cost_N_IDipN size =\n let size = S.safe_int size in\n (size * S.safe_int 4) + S.safe_int 15\n\n(* model interpreter/N_IDipN_alloc *)\n(* fun size -> max 10 (0.00283557047624 + (11.9999972146 * size)) *)\nlet cost_N_IDipN_alloc size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 12)\n\n(* model interpreter/N_IDipN_synthesized *)\n(* fun size ->\n let time = 15. + (4. * size) in\n let alloc = 0.00283557047624 + (11.9999972146 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IDipN_synthesized size =\n let size = S.safe_int size in\n S.max ((size * S.safe_int 4) + S.safe_int 15) (size * S.safe_int 12)\n\n(* model interpreter/N_IDip_alloc *)\n(* max 10 0. *)\nlet cost_N_IDip_alloc = S.safe_int 10\n\n(* model interpreter/N_IDip_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IDip_synthesized = S.safe_int 10\n\n(* model interpreter/N_IDrop *)\n(* max 10 10. *)\nlet cost_N_IDrop = S.safe_int 10\n\n(* model interpreter/N_IDropN_alloc *)\n(* fun size ->\n max 10\n ((((0. * (min 300 size)) + (0. * (sub (min 400 size) 300))) +\n (0. * (sub size 400)))\n + 0.) *)\nlet cost_N_IDropN_alloc _size = S.safe_int 10\n\n(* model interpreter/N_IDropN_synthesized *)\n(* fun size ->\n let time =\n (((2.625 * (min 300 size)) +\n (8.74162478422 * (sub (min 400 size) 300)))\n + (3.26994250393 * (sub size 400)))\n + 30. in\n let alloc =\n (((0. * (min 300 size)) + (0. * (sub (min 400 size) 300))) +\n (0. * (sub size 400)))\n + 0. in\n max 10 (max time alloc) *)\nlet cost_N_IDropN_synthesized size =\n let size = S.safe_int size in\n let w2 = S.sub size (S.safe_int 400) in\n let w3 = S.min (S.safe_int 300) size in\n let w1 = S.sub (S.min (S.safe_int 400) size) (S.safe_int 300) in\n (w1 * S.safe_int 8)\n + (w2 * S.safe_int 3)\n + (w3 * S.safe_int 2)\n + (w1 lsr 1) + (w1 lsr 2) + (w2 lsr 2) + (w2 lsr 4) + (w3 lsr 1) + (w3 lsr 3)\n + S.safe_int 30\n\n(* model interpreter/N_IDrop_alloc *)\n(* max 10 0. *)\nlet cost_N_IDrop_alloc = S.safe_int 10\n\n(* model interpreter/N_IDrop_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IDrop_synthesized = S.safe_int 10\n\n(* model interpreter/N_IDug *)\n(* fun size -> max 10 (35. + (6.75 * size)) *)\nlet cost_N_IDug size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 2) + (size * S.safe_int 6) + S.safe_int 35\n\n(* model interpreter/N_IDug_alloc *)\n(* fun size -> max 10 (11.9761359318 + (12.005966017 * size)) *)\nlet cost_N_IDug_alloc size =\n let size = S.safe_int size in\n (size lsr 2) + (size * S.safe_int 12) + S.safe_int 15\n\n(* model interpreter/N_IDug_synthesized *)\n(* fun size ->\n let time = 35. + (6.75 * size) in\n let alloc = 11.9761359318 + (12.005966017 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IDug_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 2 in\n S.max\n ((size lsr 1) + w1 + (size * S.safe_int 6) + S.safe_int 35)\n (w1 + (size * S.safe_int 12) + S.safe_int 15)\n\n(* model interpreter/N_IDup *)\n(* max 10 10. *)\nlet cost_N_IDup = S.safe_int 10\n\n(* model interpreter/N_IDupN_alloc *)\n(* fun size ->\n let size = sub size 1 in\n max 10\n ((((0. * (min 300 size)) + (0. * (sub (min 400 size) 300))) +\n (0. * (sub size 400)))\n + 12.) *)\nlet cost_N_IDupN_alloc _size = S.safe_int 15\n\n(* model interpreter/N_IDupN_synthesized *)\n(* fun size ->\n let time =\n let size = sub size 1 in\n (((1.25 * (min 300 size)) + (4.8094437716 * (sub (min 400 size) 300)))\n + (2.13759591646 * (sub size 400)))\n + 20. in\n let alloc =\n let size = sub size 1 in\n (((0. * (min 300 size)) + (0. * (sub (min 400 size) 300))) +\n (0. * (sub size 400)))\n + 12. in\n max 10 (max time alloc) *)\nlet cost_N_IDupN_synthesized size =\n let size = S.safe_int size in\n let w3 = S.sub size (S.safe_int 1) in\n let w1 = S.sub w3 (S.safe_int 400) in\n let w4 = S.min (S.safe_int 300) w3 in\n let w2 = S.sub (S.min (S.safe_int 400) w3) (S.safe_int 300) in\n (w1 * S.safe_int 2)\n + (w2 * S.safe_int 4)\n + w4 + (w1 lsr 3) + (w1 lsr 4) + (w2 lsr 1) + (w2 lsr 2) + (w2 lsr 3)\n + (w4 lsr 2) + S.safe_int 20\n\n(* model interpreter/N_IDup_alloc *)\n(* max 10 12. *)\nlet cost_N_IDup_alloc = S.safe_int 15\n\n(* model interpreter/N_IDup_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IDup_synthesized = S.safe_int 15\n\n(* model interpreter/N_IEdiv_int *)\n(* fun size1 ->\n fun size2 ->\n let q = sub size1 size2 in\n max 10\n (((((0.0010986328125 * q) * size2) + (1.25 * size1)) + (12. * q)) +\n 150.) *)\nlet cost_N_IEdiv_int size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 size2 in\n (w1 * S.safe_int 12)\n + (((w1 lsr 10) + (w1 lsr 13)) * size2)\n + (size1 lsr 2) + size1 + S.safe_int 150\n\n(* model interpreter/N_IEdiv_int_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (47.5167186214 + (0.500572259393 * (max size1 size2))) *)\nlet cost_N_IEdiv_int_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 50\n\n(* model interpreter/N_IEdiv_int_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n let q = sub size1 size2 in\n ((((0.0010986328125 * q) * size2) + (1.25 * size1)) + (12. * q)) +\n 150. in\n let alloc = 47.5167186214 + (0.500572259393 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IEdiv_int_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 size2 in\n let w2 = S.max size1 size2 in\n S.max\n ((w1 * S.safe_int 12)\n + (((w1 lsr 10) + (w1 lsr 13)) * size2)\n + (size1 lsr 2) + size1 + S.safe_int 150)\n ((w2 lsr 1) + (w2 lsr 6) + S.safe_int 50)\n\n(* model interpreter/N_IEdiv_nat *)\n(* fun size1 ->\n fun size2 ->\n let q = sub size1 size2 in\n max 10\n (((((0.0010986328125 * q) * size2) + (1.25 * size1)) + (12. * q)) +\n 150.) *)\nlet cost_N_IEdiv_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 size2 in\n (w1 * S.safe_int 12)\n + (((w1 lsr 10) + (w1 lsr 13)) * size2)\n + (size1 lsr 2) + size1 + S.safe_int 150\n\n(* model interpreter/N_IEdiv_nat_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10\n ((if size2 < size1\n then (0.500667315975 * size1) + (0. * size2)\n else 0) + 40.6929981256) *)\nlet cost_N_IEdiv_nat_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (if size2 < size1 then (size1 lsr 1) + (size1 lsr 6) else S.safe_int 0)\n + S.safe_int 45\n\n(* model interpreter/N_IEdiv_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n let q = sub size1 size2 in\n ((((0.0010986328125 * q) * size2) + (1.25 * size1)) + (12. * q)) +\n 150. in\n let alloc =\n (if size2 < size1\n then (0.500667315975 * size1) + (0. * size2)\n else 0) + 40.6929981256 in\n max 10 (max time alloc) *)\nlet cost_N_IEdiv_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 size2 in\n S.max\n ((w1 * S.safe_int 12)\n + (((w1 lsr 10) + (w1 lsr 13)) * size2)\n + (size1 lsr 2) + size1 + S.safe_int 150)\n ((if size2 < size1 then (size1 lsr 1) + (size1 lsr 6) else S.safe_int 0)\n + S.safe_int 45)\n\n(* model interpreter/N_IEdiv_tez *)\n(* max 10 80. *)\nlet cost_N_IEdiv_tez = S.safe_int 80\n\n(* model interpreter/N_IEdiv_tez_alloc *)\n(* max 10 32. *)\nlet cost_N_IEdiv_tez_alloc = S.safe_int 35\n\n(* model interpreter/N_IEdiv_tez_synthesized *)\n(* let time = 80. in let alloc = 32. in max 10 (max time alloc) *)\nlet cost_N_IEdiv_tez_synthesized = S.safe_int 80\n\n(* model interpreter/N_IEdiv_teznat *)\n(* max 10 70. *)\nlet cost_N_IEdiv_teznat = S.safe_int 70\n\n(* model interpreter/N_IEdiv_teznat_alloc *)\n(* max 10 44. *)\nlet cost_N_IEdiv_teznat_alloc = S.safe_int 45\n\n(* model interpreter/N_IEdiv_teznat_synthesized *)\n(* let time = 70. in let alloc = 44. in max 10 (max time alloc) *)\nlet cost_N_IEdiv_teznat_synthesized = S.safe_int 70\n\n(* model interpreter/N_IEmit_alloc *)\n(* max 10 124. *)\nlet cost_N_IEmit_alloc = S.safe_int 125\n\n(* model interpreter/N_IEmit_synthesized *)\n(* let time = 30. in let alloc = 124. in max 10 (max time alloc) *)\nlet cost_N_IEmit_synthesized = S.safe_int 125\n\n(* model interpreter/N_IEmpty_big_map *)\n(* max 10 300. *)\nlet cost_N_IEmpty_big_map = S.safe_int 300\n\n(* model interpreter/N_IEmpty_big_map_alloc *)\n(* max 10 44. *)\nlet cost_N_IEmpty_big_map_alloc = S.safe_int 45\n\n(* model interpreter/N_IEmpty_big_map_synthesized *)\n(* let time = 300. in let alloc = 44. in max 10 (max time alloc) *)\nlet cost_N_IEmpty_big_map_synthesized = S.safe_int 300\n\n(* model interpreter/N_IEmpty_map *)\n(* max 10 300. *)\nlet cost_N_IEmpty_map = S.safe_int 300\n\n(* model interpreter/N_IEmpty_map_alloc *)\n(* max 10 248. *)\nlet cost_N_IEmpty_map_alloc = S.safe_int 250\n\n(* model interpreter/N_IEmpty_map_synthesized *)\n(* let time = 300. in let alloc = 248. in max 10 (max time alloc) *)\nlet cost_N_IEmpty_map_synthesized = S.safe_int 300\n\n(* model interpreter/N_IEmpty_set *)\n(* max 10 300. *)\nlet cost_N_IEmpty_set = S.safe_int 300\n\n(* model interpreter/N_IEmpty_set_alloc *)\n(* max 10 184. *)\nlet cost_N_IEmpty_set_alloc = S.safe_int 185\n\n(* model interpreter/N_IEmpty_set_synthesized *)\n(* let time = 300. in let alloc = 184. in max 10 (max time alloc) *)\nlet cost_N_IEmpty_set_synthesized = S.safe_int 300\n\n(* model interpreter/N_IEq *)\n(* max 10 10. *)\nlet cost_N_IEq = S.safe_int 10\n\n(* model interpreter/N_IEq_alloc *)\n(* max 10 0. *)\nlet cost_N_IEq_alloc = S.safe_int 10\n\n(* model interpreter/N_IEq_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IEq_synthesized = S.safe_int 10\n\n(* model interpreter/N_IExec *)\n(* max 10 10. *)\nlet cost_N_IExec = S.safe_int 10\n\n(* model interpreter/N_IExec_alloc *)\n(* max 10 0. *)\nlet cost_N_IExec_alloc = S.safe_int 10\n\n(* model interpreter/N_IExec_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IExec_synthesized = S.safe_int 10\n\n(* model interpreter/N_IFailwith *)\n(* max 10 167.455190659 *)\nlet cost_N_IFailwith = S.safe_int 170\n\n(* model interpreter/N_IFailwith_alloc *)\n(* max 10 0. *)\nlet cost_N_IFailwith_alloc = S.safe_int 10\n\n(* model interpreter/N_IFailwith_synthesized *)\n(* let time = 167.455190659 in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IFailwith_synthesized = S.safe_int 170\n\n(* model interpreter/N_IGe *)\n(* max 10 10. *)\nlet cost_N_IGe = S.safe_int 10\n\n(* model interpreter/N_IGe_alloc *)\n(* max 10 0. *)\nlet cost_N_IGe_alloc = S.safe_int 10\n\n(* model interpreter/N_IGe_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IGe_synthesized = S.safe_int 10\n\n(* model interpreter/N_IGt *)\n(* max 10 10. *)\nlet cost_N_IGt = S.safe_int 10\n\n(* model interpreter/N_IGt_alloc *)\n(* max 10 0. *)\nlet cost_N_IGt_alloc = S.safe_int 10\n\n(* model interpreter/N_IGt_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IGt_synthesized = S.safe_int 10\n\n(* model interpreter/N_IHalt *)\n(* max 10 15. *)\nlet cost_N_IHalt = S.safe_int 15\n\n(* model interpreter/N_IHalt_alloc *)\n(* max 10 0. *)\nlet cost_N_IHalt_alloc = S.safe_int 10\n\n(* model interpreter/N_IHalt_synthesized *)\n(* let time = 15. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IHalt_synthesized = S.safe_int 15\n\n(* model interpreter/N_IHash_key *)\n(* max 10 605. *)\nlet cost_N_IHash_key = S.safe_int 605\n\n(* model interpreter/N_IHash_key_alloc *)\n(* max 10 32. *)\nlet cost_N_IHash_key_alloc = S.safe_int 35\n\n(* model interpreter/N_IHash_key_synthesized *)\n(* let time = 605. in let alloc = 32. in max 10 (max time alloc) *)\nlet cost_N_IHash_key_synthesized = S.safe_int 605\n\n(* model interpreter/N_IIf *)\n(* max 10 10. *)\nlet cost_N_IIf = S.safe_int 10\n\n(* model interpreter/N_IIf_alloc *)\n(* max 10 0. *)\nlet cost_N_IIf_alloc = S.safe_int 10\n\n(* model interpreter/N_IIf_cons *)\n(* max 10 10. *)\nlet cost_N_IIf_cons = S.safe_int 10\n\n(* model interpreter/N_IIf_cons_alloc *)\n(* max 10 0. *)\nlet cost_N_IIf_cons_alloc = S.safe_int 10\n\n(* model interpreter/N_IIf_cons_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IIf_cons_synthesized = S.safe_int 10\n\n(* model interpreter/N_IIf_left *)\n(* max 10 10. *)\nlet cost_N_IIf_left = S.safe_int 10\n\n(* model interpreter/N_IIf_left_alloc *)\n(* max 10 0. *)\nlet cost_N_IIf_left_alloc = S.safe_int 10\n\n(* model interpreter/N_IIf_left_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IIf_left_synthesized = S.safe_int 10\n\n(* model interpreter/N_IIf_none *)\n(* max 10 10. *)\nlet cost_N_IIf_none = S.safe_int 10\n\n(* model interpreter/N_IIf_none_alloc *)\n(* max 10 0. *)\nlet cost_N_IIf_none_alloc = S.safe_int 10\n\n(* model interpreter/N_IIf_none_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IIf_none_synthesized = S.safe_int 10\n\n(* model interpreter/N_IIf_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IIf_synthesized = S.safe_int 10\n\n(* model interpreter/N_IImplicit_account *)\n(* max 10 10. *)\nlet cost_N_IImplicit_account = S.safe_int 10\n\n(* model interpreter/N_IImplicit_account_alloc *)\n(* max 10 8. *)\nlet cost_N_IImplicit_account_alloc = S.safe_int 10\n\n(* model interpreter/N_IImplicit_account_synthesized *)\n(* let time = 10. in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_IImplicit_account_synthesized = S.safe_int 10\n\n(* model interpreter/N_IInt_bls12_381_z_fr *)\n(* max 10 115. *)\nlet cost_N_IInt_bls12_381_z_fr = S.safe_int 115\n\n(* model interpreter/N_IInt_bls12_381_z_fr_alloc *)\n(* max 10 28. *)\nlet cost_N_IInt_bls12_381_z_fr_alloc = S.safe_int 30\n\n(* model interpreter/N_IInt_bls12_381_z_fr_synthesized *)\n(* let time = 115. in let alloc = 28. in max 10 (max time alloc) *)\nlet cost_N_IInt_bls12_381_z_fr_synthesized = S.safe_int 115\n\n(* model interpreter/N_IInt_bytes *)\n(* fun size -> max 10 (20. + (2.5 * size)) *)\nlet cost_N_IInt_bytes size =\n let size = S.safe_int size in\n (size lsr 1) + (size * S.safe_int 2) + S.safe_int 20\n\n(* model interpreter/N_IInt_bytes_alloc *)\n(* fun size -> max 10 (15.3727158555 + (0.505091365778 * size)) *)\nlet cost_N_IInt_bytes_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 15\n\n(* model interpreter/N_IInt_bytes_synthesized *)\n(* fun size ->\n let time = 20. + (2.5 * size) in\n let alloc = 15.3727158555 + (0.505091365778 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IInt_bytes_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max\n (w1 + (size * S.safe_int 2) + S.safe_int 20)\n (w1 + (size lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_IInt_nat *)\n(* max 10 10. *)\nlet cost_N_IInt_nat = S.safe_int 10\n\n(* model interpreter/N_IInt_nat_alloc *)\n(* max 10 0. *)\nlet cost_N_IInt_nat_alloc = S.safe_int 10\n\n(* model interpreter/N_IInt_nat_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IInt_nat_synthesized = S.safe_int 10\n\n(* model interpreter/N_IIs_nat *)\n(* max 10 10. *)\nlet cost_N_IIs_nat = S.safe_int 10\n\n(* model interpreter/N_IIs_nat_alloc *)\n(* max 10 8. *)\nlet cost_N_IIs_nat_alloc = S.safe_int 10\n\n(* model interpreter/N_IIs_nat_synthesized *)\n(* let time = 10. in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_IIs_nat_synthesized = S.safe_int 10\n\n(* model interpreter/N_IJoin_tickets *)\n(* fun content_size_x ->\n fun content_size_y ->\n fun amount_size_x ->\n fun amount_size_y ->\n max 10\n ((88.1705426747 + (0. * (min content_size_x content_size_y))) +\n (0.0788934824125 * (max amount_size_x amount_size_y))) *)\nlet cost_N_IJoin_tickets _content_size_x _content_size_y amount_size_x\n amount_size_y =\n let amount_size_x = S.safe_int amount_size_x in\n let amount_size_y = S.safe_int amount_size_y in\n let w1 = S.max amount_size_x amount_size_y in\n (w1 lsr 4) + (w1 lsr 6) + (w1 lsr 9) + S.safe_int 90\n\n(* model interpreter/N_IJoin_tickets_alloc *)\n(* fun content_size_x ->\n fun content_size_y ->\n fun amount_size_x ->\n fun amount_size_y ->\n max 10\n (42.1137922063 +\n (0.500124881342 * (max amount_size_x amount_size_y))) *)\nlet cost_N_IJoin_tickets_alloc _content_size_x _content_size_y amount_size_x\n amount_size_y =\n let amount_size_x = S.safe_int amount_size_x in\n let amount_size_y = S.safe_int amount_size_y in\n let w1 = S.max amount_size_x amount_size_y in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 45\n\n(* model interpreter/N_IJoin_tickets_synthesized *)\n(* fun content_size_x ->\n fun content_size_y ->\n fun amount_size_x ->\n fun amount_size_y ->\n let time =\n (88.1705426747 + (0. * (min content_size_x content_size_y))) +\n (0.0788934824125 * (max amount_size_x amount_size_y)) in\n let alloc =\n 42.1137922063 +\n (0.500124881342 * (max amount_size_x amount_size_y)) in\n max 10 (max time alloc) *)\nlet cost_N_IJoin_tickets_synthesized _content_size_x _content_size_y\n amount_size_x amount_size_y =\n let amount_size_x = S.safe_int amount_size_x in\n let amount_size_y = S.safe_int amount_size_y in\n let w1 = S.max amount_size_x amount_size_y in\n let w2 = w1 lsr 6 in\n S.max\n ((w1 lsr 4) + w2 + (w1 lsr 9) + S.safe_int 90)\n ((w1 lsr 1) + w2 + S.safe_int 45)\n\n(* model interpreter/N_IKeccak *)\n(* fun size -> max 10 (1350. + (8.25 * size)) *)\nlet cost_N_IKeccak size =\n let size = S.safe_int size in\n (size lsr 2) + (size * S.safe_int 8) + S.safe_int 1350\n\n(* model interpreter/N_IKeccak_alloc *)\n(* fun size -> max 10 24. *)\nlet cost_N_IKeccak_alloc _size = S.safe_int 25\n\n(* model interpreter/N_IKeccak_synthesized *)\n(* fun size ->\n let time = 1350. + (8.25 * size) in\n let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_IKeccak_synthesized size =\n let size = S.safe_int size in\n (size lsr 2) + (size * S.safe_int 8) + S.safe_int 1350\n\n(* model interpreter/N_ILambda *)\n(* max 10 (max 10. 10.) *)\nlet cost_N_ILambda = S.safe_int 10\n\n(* model interpreter/N_ILambda_lam *)\n(* max 10 10. *)\nlet cost_N_ILambda_lam = S.safe_int 10\n\n(* model interpreter/N_ILambda_lam_alloc *)\n(* max 10 68. *)\nlet cost_N_ILambda_lam_alloc = S.safe_int 70\n\n(* model interpreter/N_ILambda_lam_synthesized *)\n(* let time = 10. in let alloc = 68. in max 10 (max time alloc) *)\nlet cost_N_ILambda_lam_synthesized = S.safe_int 70\n\n(* model interpreter/N_ILambda_lamrec *)\n(* max 10 10. *)\nlet cost_N_ILambda_lamrec = S.safe_int 10\n\n(* model interpreter/N_ILambda_lamrec_alloc *)\n(* max 10 140. *)\nlet cost_N_ILambda_lamrec_alloc = S.safe_int 140\n\n(* model interpreter/N_ILambda_lamrec_synthesized *)\n(* let time = 10. in let alloc = 140. in max 10 (max time alloc) *)\nlet cost_N_ILambda_lamrec_synthesized = S.safe_int 140\n\n(* model interpreter/N_ILe *)\n(* max 10 10. *)\nlet cost_N_ILe = S.safe_int 10\n\n(* model interpreter/N_ILe_alloc *)\n(* max 10 0. *)\nlet cost_N_ILe_alloc = S.safe_int 10\n\n(* model interpreter/N_ILe_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ILe_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILeft *)\n(* max 10 10. *)\nlet cost_N_ILeft = S.safe_int 10\n\n(* model interpreter/N_ILeft_alloc *)\n(* max 10 8. *)\nlet cost_N_ILeft_alloc = S.safe_int 10\n\n(* model interpreter/N_ILeft_synthesized *)\n(* let time = 10. in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_ILeft_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILevel *)\n(* max 10 10. *)\nlet cost_N_ILevel = S.safe_int 10\n\n(* model interpreter/N_ILevel_alloc *)\n(* max 10 12. *)\nlet cost_N_ILevel_alloc = S.safe_int 15\n\n(* model interpreter/N_ILevel_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_ILevel_synthesized = S.safe_int 15\n\n(* model interpreter/N_IList_iter *)\n(* max 10 20. *)\nlet cost_N_IList_iter = S.safe_int 20\n\n(* model interpreter/N_IList_iter_alloc *)\n(* max 10 0. *)\nlet cost_N_IList_iter_alloc = S.safe_int 10\n\n(* model interpreter/N_IList_iter_synthesized *)\n(* let time = 20. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IList_iter_synthesized = S.safe_int 20\n\n(* model interpreter/N_IList_map *)\n(* max 10 20. *)\nlet cost_N_IList_map = S.safe_int 20\n\n(* model interpreter/N_IList_map_alloc *)\n(* max 10 1. *)\nlet cost_N_IList_map_alloc = S.safe_int 10\n\n(* model interpreter/N_IList_map_synthesized *)\n(* let time = 20. in let alloc = 1. in max 10 (max time alloc) *)\nlet cost_N_IList_map_synthesized = S.safe_int 20\n\n(* model interpreter/N_IList_size *)\n(* max 10 10. *)\nlet cost_N_IList_size = S.safe_int 10\n\n(* model interpreter/N_IList_size_alloc *)\n(* max 10 0. *)\nlet cost_N_IList_size_alloc = S.safe_int 10\n\n(* model interpreter/N_IList_size_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IList_size_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILoop *)\n(* max 10 (max 10. 1.01451868265) *)\nlet cost_N_ILoop = S.safe_int 10\n\n(* model interpreter/N_ILoop_in *)\n(* max 10 10. *)\nlet cost_N_ILoop_in = S.safe_int 10\n\n(* model interpreter/N_ILoop_in_alloc *)\n(* max 10 0. *)\nlet cost_N_ILoop_in_alloc = S.safe_int 10\n\n(* model interpreter/N_ILoop_in_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ILoop_in_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILoop_left *)\n(* max 10 (max 10. 10.) *)\nlet cost_N_ILoop_left = S.safe_int 10\n\n(* model interpreter/N_ILoop_left_in *)\n(* max 10 10. *)\nlet cost_N_ILoop_left_in = S.safe_int 10\n\n(* model interpreter/N_ILoop_left_in_alloc *)\n(* max 10 0. *)\nlet cost_N_ILoop_left_in_alloc = S.safe_int 10\n\n(* model interpreter/N_ILoop_left_in_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ILoop_left_in_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILoop_left_out *)\n(* max 10 10. *)\nlet cost_N_ILoop_left_out = S.safe_int 10\n\n(* model interpreter/N_ILoop_left_out_alloc *)\n(* max 10 0. *)\nlet cost_N_ILoop_left_out_alloc = S.safe_int 10\n\n(* model interpreter/N_ILoop_left_out_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ILoop_left_out_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILoop_out *)\n(* max 10 1.01451868265 *)\nlet cost_N_ILoop_out = S.safe_int 10\n\n(* model interpreter/N_ILoop_out_alloc *)\n(* max 10 0. *)\nlet cost_N_ILoop_out_alloc = S.safe_int 10\n\n(* model interpreter/N_ILoop_out_synthesized *)\n(* let time = 1.01451868265 in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ILoop_out_synthesized = S.safe_int 10\n\n(* model interpreter/N_ILsl_bytes_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10\n ((11.757438371 + (0.500014421862 * size1)) +\n (0.0624426926223 * (sub size2 1))) *)\nlet cost_N_ILsl_bytes_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.sub size2 (S.safe_int 1) lsr 4)\n + (size1 lsr 1) + (size1 lsr 6) + S.safe_int 15\n\n(* model interpreter/N_ILsl_bytes_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = (65. + (0.75 * size1)) + (0.0625 * (sub size2 1)) in\n let alloc =\n (11.757438371 + (0.500014421862 * size1)) +\n (0.0624426926223 * (sub size2 1)) in\n max 10 (max time alloc) *)\nlet cost_N_ILsl_bytes_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = (S.sub size2 (S.safe_int 1) lsr 4) + (size1 lsr 1) in\n S.max (w1 + (size1 lsr 2) + S.safe_int 65) (w1 + (size1 lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_ILsl_nat_alloc *)\n(* fun size -> max 10 (29.0640101265 + (0.500355618928 * size)) *)\nlet cost_N_ILsl_nat_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 30\n\n(* model interpreter/N_ILsl_nat_synthesized *)\n(* fun size ->\n let time = 128. + (0.5 * size) in\n let alloc = 29.0640101265 + (0.500355618928 * size) in\n max 10 (max time alloc) *)\nlet cost_N_ILsl_nat_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 130) (w1 + (size lsr 6) + S.safe_int 30)\n\n(* model interpreter/N_ILsr_bytes *)\n(* fun size1 ->\n fun size2 ->\n let q = sub size1 (size2 * 0.125) in max 10 (55. + (0.75 * q)) *)\nlet cost_N_ILsr_bytes size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 (size2 lsr 3) in\n (w1 lsr 1) + (w1 lsr 2) + S.safe_int 55\n\n(* model interpreter/N_ILsr_bytes_alloc *)\n(* fun size1 ->\n fun size2 ->\n let q = sub size1 (size2 * 0.125) in\n max 10 (11.1748222186 + (0.499974561517 * q)) *)\nlet cost_N_ILsr_bytes_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.sub size1 (size2 lsr 3) lsr 1) + S.safe_int 15\n\n(* model interpreter/N_ILsr_bytes_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = let q = sub size1 (size2 * 0.125) in 55. + (0.75 * q) in\n let alloc =\n let q = sub size1 (size2 * 0.125) in\n 11.1748222186 + (0.499974561517 * q) in\n max 10 (max time alloc) *)\nlet cost_N_ILsr_bytes_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 (size2 lsr 3) in\n (w1 lsr 1) + (w1 lsr 2) + S.safe_int 55\n\n(* model interpreter/N_ILsr_nat *)\n(* fun size -> max 10 (45. + (0.5 * size)) *)\nlet cost_N_ILsr_nat size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 45\n\n(* model interpreter/N_ILsr_nat_alloc *)\n(* fun size -> max 10 (19.6693071446 + (0.500176652166 * size)) *)\nlet cost_N_ILsr_nat_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 20\n\n(* model interpreter/N_ILsr_nat_synthesized *)\n(* fun size ->\n let time = 45. + (0.5 * size) in\n let alloc = 19.6693071446 + (0.500176652166 * size) in\n max 10 (max time alloc) *)\nlet cost_N_ILsr_nat_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 45) (w1 + (size lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_ILt *)\n(* max 10 10. *)\nlet cost_N_ILt = S.safe_int 10\n\n(* model interpreter/N_ILt_alloc *)\n(* max 10 0. *)\nlet cost_N_ILt_alloc = S.safe_int 10\n\n(* model interpreter/N_ILt_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ILt_synthesized = S.safe_int 10\n\n(* model interpreter/N_IMap_get *)\n(* fun size1 ->\n fun size2 -> max 10 (45. + (0.046875 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IMap_get size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 5) + (w3 lsr 6) + S.safe_int 45\n\n(* model interpreter/N_IMap_get_alloc *)\n(* fun size1 -> fun size2 -> max 10 8. *)\nlet cost_N_IMap_get_alloc _size1 _size2 = S.safe_int 10\n\n(* model interpreter/N_IMap_get_and_update *)\n(* fun size1 ->\n fun size2 -> max 10 (75. + (0.140625 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IMap_get_and_update size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 3) + (w3 lsr 6) + S.safe_int 75\n\n(* model interpreter/N_IMap_get_and_update_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((27.8275684249 * (log2 (1 + size2))) + 90.906332394) *)\nlet cost_N_IMap_get_and_update_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n (log2 (size2 + S.safe_int 1) * S.safe_int 28) + S.safe_int 95\n\n(* model interpreter/N_IMap_get_and_update_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 75. + (0.140625 * (size1 * (log2 (1 + size2)))) in\n let alloc = (27.8275684249 * (log2 (1 + size2))) + 90.906332394 in\n max 10 (max time alloc) *)\nlet cost_N_IMap_get_and_update_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n let w3 = w1 * size1 in\n S.max\n ((w3 lsr 3) + (w3 lsr 6) + S.safe_int 75)\n ((w1 * S.safe_int 28) + S.safe_int 95)\n\n(* model interpreter/N_IMap_get_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 45. + (0.046875 * (size1 * (log2 (1 + size2)))) in\n let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_IMap_get_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 5) + (w3 lsr 6) + S.safe_int 45\n\n(* model interpreter/N_IMap_iter *)\n(* fun size -> max 10 (50. + (7.625 * size)) *)\nlet cost_N_IMap_iter size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 3) + (size * S.safe_int 7) + S.safe_int 50\n\n(* model interpreter/N_IMap_iter_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_IMap_iter_alloc _size = S.safe_int 10\n\n(* model interpreter/N_IMap_iter_synthesized *)\n(* fun size ->\n let time = 50. + (7.625 * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IMap_iter_synthesized size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 3) + (size * S.safe_int 7) + S.safe_int 50\n\n(* model interpreter/N_IMap_map *)\n(* fun size -> max 10 (40. + (8.5 * size)) *)\nlet cost_N_IMap_map size =\n let size = S.safe_int size in\n (size lsr 1) + (size * S.safe_int 8) + S.safe_int 40\n\n(* model interpreter/N_IMap_map_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_IMap_map_alloc _size = S.safe_int 10\n\n(* model interpreter/N_IMap_map_synthesized *)\n(* fun size ->\n let time = 40. + (8.5 * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IMap_map_synthesized size =\n let size = S.safe_int size in\n (size lsr 1) + (size * S.safe_int 8) + S.safe_int 40\n\n(* model interpreter/N_IMap_mem *)\n(* fun size1 ->\n fun size2 -> max 10 (45. + (0.046875 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IMap_mem size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 5) + (w3 lsr 6) + S.safe_int 45\n\n(* model interpreter/N_IMap_mem_alloc *)\n(* fun size1 -> fun size2 -> max 10 0. *)\nlet cost_N_IMap_mem_alloc _size1 _size2 = S.safe_int 10\n\n(* model interpreter/N_IMap_mem_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 45. + (0.046875 * (size1 * (log2 (1 + size2)))) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IMap_mem_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 5) + (w3 lsr 6) + S.safe_int 45\n\n(* model interpreter/N_IMap_size *)\n(* max 10 10. *)\nlet cost_N_IMap_size = S.safe_int 10\n\n(* model interpreter/N_IMap_size_alloc *)\n(* max 10 0. *)\nlet cost_N_IMap_size_alloc = S.safe_int 10\n\n(* model interpreter/N_IMap_size_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IMap_size_synthesized = S.safe_int 10\n\n(* model interpreter/N_IMap_update *)\n(* fun size1 ->\n fun size2 -> max 10 (55. + (0.09375 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_IMap_update size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 4) + (w3 lsr 5) + S.safe_int 55\n\n(* model interpreter/N_IMap_update_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((27.8275684249 * (log2 (1 + size2))) + 78.906332394) *)\nlet cost_N_IMap_update_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n (log2 (size2 + S.safe_int 1) * S.safe_int 28) + S.safe_int 80\n\n(* model interpreter/N_IMap_update_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 55. + (0.09375 * (size1 * (log2 (1 + size2)))) in\n let alloc = (27.8275684249 * (log2 (1 + size2))) + 78.906332394 in\n max 10 (max time alloc) *)\nlet cost_N_IMap_update_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n let w3 = w1 * size1 in\n S.max\n ((w3 lsr 4) + (w3 lsr 5) + S.safe_int 55)\n ((w1 * S.safe_int 28) + S.safe_int 80)\n\n(* model interpreter/N_IMin_block_time *)\n(* max 10 20. *)\nlet cost_N_IMin_block_time = S.safe_int 20\n\n(* model interpreter/N_IMin_block_time_alloc *)\n(* max 10 12. *)\nlet cost_N_IMin_block_time_alloc = S.safe_int 15\n\n(* model interpreter/N_IMin_block_time_synthesized *)\n(* let time = 20. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IMin_block_time_synthesized = S.safe_int 20\n\n(* model interpreter/N_IMul_bls12_381_fr *)\n(* max 10 45. *)\nlet cost_N_IMul_bls12_381_fr = S.safe_int 45\n\n(* model interpreter/N_IMul_bls12_381_fr_alloc *)\n(* max 10 24. *)\nlet cost_N_IMul_bls12_381_fr_alloc = S.safe_int 25\n\n(* model interpreter/N_IMul_bls12_381_fr_synthesized *)\n(* let time = 45. in let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_IMul_bls12_381_fr_synthesized = S.safe_int 45\n\n(* model interpreter/N_IMul_bls12_381_fr_z *)\n(* fun size -> max 10 (265. + (1.0625 * size)) *)\nlet cost_N_IMul_bls12_381_fr_z size =\n let size = S.safe_int size in\n (size lsr 4) + size + S.safe_int 265\n\n(* model interpreter/N_IMul_bls12_381_fr_z_alloc *)\n(* fun size -> max 10 24. *)\nlet cost_N_IMul_bls12_381_fr_z_alloc _size = S.safe_int 25\n\n(* model interpreter/N_IMul_bls12_381_fr_z_synthesized *)\n(* fun size ->\n let time = 265. + (1.0625 * size) in\n let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_IMul_bls12_381_fr_z_synthesized size =\n let size = S.safe_int size in\n (size lsr 4) + size + S.safe_int 265\n\n(* model interpreter/N_IMul_bls12_381_g1 *)\n(* max 10 103000. *)\nlet cost_N_IMul_bls12_381_g1 = S.safe_int 103000\n\n(* model interpreter/N_IMul_bls12_381_g1_alloc *)\n(* max 10 80. *)\nlet cost_N_IMul_bls12_381_g1_alloc = S.safe_int 80\n\n(* model interpreter/N_IMul_bls12_381_g1_synthesized *)\n(* let time = 103000. in let alloc = 80. in max 10 (max time alloc) *)\nlet cost_N_IMul_bls12_381_g1_synthesized = S.safe_int 103000\n\n(* model interpreter/N_IMul_bls12_381_g2 *)\n(* max 10 220000. *)\nlet cost_N_IMul_bls12_381_g2 = S.safe_int 220000\n\n(* model interpreter/N_IMul_bls12_381_g2_alloc *)\n(* max 10 152. *)\nlet cost_N_IMul_bls12_381_g2_alloc = S.safe_int 155\n\n(* model interpreter/N_IMul_bls12_381_g2_synthesized *)\n(* let time = 220000. in let alloc = 152. in max 10 (max time alloc) *)\nlet cost_N_IMul_bls12_381_g2_synthesized = S.safe_int 220000\n\n(* model interpreter/N_IMul_bls12_381_z_fr *)\n(* fun size -> max 10 (265. + (1.0625 * size)) *)\nlet cost_N_IMul_bls12_381_z_fr size =\n let size = S.safe_int size in\n (size lsr 4) + size + S.safe_int 265\n\n(* model interpreter/N_IMul_bls12_381_z_fr_alloc *)\n(* fun size -> max 10 24. *)\nlet cost_N_IMul_bls12_381_z_fr_alloc _size = S.safe_int 25\n\n(* model interpreter/N_IMul_bls12_381_z_fr_synthesized *)\n(* fun size ->\n let time = 265. + (1.0625 * size) in\n let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_IMul_bls12_381_z_fr_synthesized size =\n let size = S.safe_int size in\n (size lsr 4) + size + S.safe_int 265\n\n(* model interpreter/N_IMul_int *)\n(* fun size1 ->\n fun size2 ->\n let a = size1 + size2 in\n max 10 ((0.8125 * (a * (log2 (1 + a)))) + 55.) *)\nlet cost_N_IMul_int size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = size1 + size2 in\n let w4 = log2 (w3 + S.safe_int 1) * w3 in\n (w4 lsr 1) + (w4 lsr 2) + (w4 lsr 4) + S.safe_int 55\n\n(* model interpreter/N_IMul_int_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (16.9221412881 + (0.500135612537 * (size1 + size2))) *)\nlet cost_N_IMul_int_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = size1 + size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_IMul_int_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n let a = size1 + size2 in (0.8125 * (a * (log2 (1 + a)))) + 55. in\n let alloc = 16.9221412881 + (0.500135612537 * (size1 + size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IMul_int_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = size1 + size2 in\n let w4 = log2 (w3 + S.safe_int 1) * w3 in\n S.max\n ((w4 lsr 1) + (w4 lsr 2) + (w4 lsr 4) + S.safe_int 55)\n ((w3 lsr 1) + (w3 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_IMul_nat *)\n(* fun size1 ->\n fun size2 ->\n let a = size1 + size2 in\n max 10 ((0.8125 * (a * (log2 (1 + a)))) + 55.) *)\nlet cost_N_IMul_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = size1 + size2 in\n let w4 = log2 (w3 + S.safe_int 1) * w3 in\n (w4 lsr 1) + (w4 lsr 2) + (w4 lsr 4) + S.safe_int 55\n\n(* model interpreter/N_IMul_nat_alloc *)\n(* fun size1 ->\n fun size2 -> max 10 (15.2155091333 + (0.500139029901 * (size1 + size2))) *)\nlet cost_N_IMul_nat_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = size1 + size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 15\n\n(* model interpreter/N_IMul_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n let a = size1 + size2 in (0.8125 * (a * (log2 (1 + a)))) + 55. in\n let alloc = 15.2155091333 + (0.500139029901 * (size1 + size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IMul_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = size1 + size2 in\n let w4 = log2 (w3 + S.safe_int 1) * w3 in\n S.max\n ((w4 lsr 1) + (w4 lsr 2) + (w4 lsr 4) + S.safe_int 55)\n ((w3 lsr 1) + (w3 lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_IMul_nattez *)\n(* max 10 50. *)\nlet cost_N_IMul_nattez = S.safe_int 50\n\n(* model interpreter/N_IMul_nattez_alloc *)\n(* max 10 12. *)\nlet cost_N_IMul_nattez_alloc = S.safe_int 15\n\n(* model interpreter/N_IMul_nattez_synthesized *)\n(* let time = 50. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IMul_nattez_synthesized = S.safe_int 50\n\n(* model interpreter/N_IMul_teznat *)\n(* max 10 50. *)\nlet cost_N_IMul_teznat = S.safe_int 50\n\n(* model interpreter/N_IMul_teznat_alloc *)\n(* max 10 12. *)\nlet cost_N_IMul_teznat_alloc = S.safe_int 15\n\n(* model interpreter/N_IMul_teznat_synthesized *)\n(* let time = 50. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IMul_teznat_synthesized = S.safe_int 50\n\n(* model interpreter/N_INat_bytes *)\n(* fun size -> max 10 (45. + (2.5 * size)) *)\nlet cost_N_INat_bytes size =\n let size = S.safe_int size in\n (size lsr 1) + (size * S.safe_int 2) + S.safe_int 45\n\n(* model interpreter/N_INat_bytes_alloc *)\n(* fun size -> max 10 (15.3744531872 + (0.505021872511 * size)) *)\nlet cost_N_INat_bytes_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 15\n\n(* model interpreter/N_INat_bytes_synthesized *)\n(* fun size ->\n let time = 45. + (2.5 * size) in\n let alloc = 15.3744531872 + (0.505021872511 * size) in\n max 10 (max time alloc) *)\nlet cost_N_INat_bytes_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max\n (w1 + (size * S.safe_int 2) + S.safe_int 45)\n (w1 + (size lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_INeg *)\n(* fun size -> max 10 (25. + (0.5 * size)) *)\nlet cost_N_INeg size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 25\n\n(* model interpreter/N_INeg_alloc *)\n(* fun size -> max 10 (15.6123273039 + (0.500207090115 * size)) *)\nlet cost_N_INeg_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 20\n\n(* model interpreter/N_INeg_bls12_381_fr *)\n(* max 10 30. *)\nlet cost_N_INeg_bls12_381_fr = S.safe_int 30\n\n(* model interpreter/N_INeg_bls12_381_fr_alloc *)\n(* max 10 24. *)\nlet cost_N_INeg_bls12_381_fr_alloc = S.safe_int 25\n\n(* model interpreter/N_INeg_bls12_381_fr_synthesized *)\n(* let time = 30. in let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_INeg_bls12_381_fr_synthesized = S.safe_int 30\n\n(* model interpreter/N_INeg_bls12_381_g1 *)\n(* max 10 50. *)\nlet cost_N_INeg_bls12_381_g1 = S.safe_int 50\n\n(* model interpreter/N_INeg_bls12_381_g1_alloc *)\n(* max 10 80. *)\nlet cost_N_INeg_bls12_381_g1_alloc = S.safe_int 80\n\n(* model interpreter/N_INeg_bls12_381_g1_synthesized *)\n(* let time = 50. in let alloc = 80. in max 10 (max time alloc) *)\nlet cost_N_INeg_bls12_381_g1_synthesized = S.safe_int 80\n\n(* model interpreter/N_INeg_bls12_381_g2 *)\n(* max 10 70. *)\nlet cost_N_INeg_bls12_381_g2 = S.safe_int 70\n\n(* model interpreter/N_INeg_bls12_381_g2_alloc *)\n(* max 10 152. *)\nlet cost_N_INeg_bls12_381_g2_alloc = S.safe_int 155\n\n(* model interpreter/N_INeg_bls12_381_g2_synthesized *)\n(* let time = 70. in let alloc = 152. in max 10 (max time alloc) *)\nlet cost_N_INeg_bls12_381_g2_synthesized = S.safe_int 155\n\n(* model interpreter/N_INeg_synthesized *)\n(* fun size ->\n let time = 25. + (0.5 * size) in\n let alloc = 15.6123273039 + (0.500207090115 * size) in\n max 10 (max time alloc) *)\nlet cost_N_INeg_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 25) (w1 + (size lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_INeq *)\n(* max 10 10. *)\nlet cost_N_INeq = S.safe_int 10\n\n(* model interpreter/N_INeq_alloc *)\n(* max 10 0. *)\nlet cost_N_INeq_alloc = S.safe_int 10\n\n(* model interpreter/N_INeq_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_INeq_synthesized = S.safe_int 10\n\n(* model interpreter/N_INil *)\n(* max 10 10. *)\nlet cost_N_INil = S.safe_int 10\n\n(* model interpreter/N_INil_alloc *)\n(* max 10 12. *)\nlet cost_N_INil_alloc = S.safe_int 15\n\n(* model interpreter/N_INil_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_INil_synthesized = S.safe_int 15\n\n(* model interpreter/N_INot *)\n(* max 10 10. *)\nlet cost_N_INot = S.safe_int 10\n\n(* model interpreter/N_INot_alloc *)\n(* max 10 0. *)\nlet cost_N_INot_alloc = S.safe_int 10\n\n(* model interpreter/N_INot_bytes *)\n(* fun size -> max 10 (30. + (0.5 * size)) *)\nlet cost_N_INot_bytes size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 30\n\n(* model interpreter/N_INot_bytes_alloc *)\n(* fun size -> max 10 (10.5493304199 + (0.499980342588 * size)) *)\nlet cost_N_INot_bytes_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 15\n\n(* model interpreter/N_INot_bytes_synthesized *)\n(* fun size ->\n let time = 30. + (0.5 * size) in\n let alloc = 10.5493304199 + (0.499980342588 * size) in\n max 10 (max time alloc) *)\nlet cost_N_INot_bytes_synthesized size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 30\n\n(* model interpreter/N_INot_int *)\n(* fun size -> max 10 (25. + (0.5 * size)) *)\nlet cost_N_INot_int size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 25\n\n(* model interpreter/N_INot_int_alloc *)\n(* fun size -> max 10 (19.5017942553 + (0.500266135547 * size)) *)\nlet cost_N_INot_int_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 20\n\n(* model interpreter/N_INot_int_synthesized *)\n(* fun size ->\n let time = 25. + (0.5 * size) in\n let alloc = 19.5017942553 + (0.500266135547 * size) in\n max 10 (max time alloc) *)\nlet cost_N_INot_int_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 25) (w1 + (size lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_INot_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_INot_synthesized = S.safe_int 10\n\n(* model interpreter/N_INow *)\n(* max 10 10. *)\nlet cost_N_INow = S.safe_int 10\n\n(* model interpreter/N_INow_alloc *)\n(* max 10 12. *)\nlet cost_N_INow_alloc = S.safe_int 15\n\n(* model interpreter/N_INow_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_INow_synthesized = S.safe_int 15\n\n(* model interpreter/N_IOpen_chest *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((919000. + (22528. * (sub size1 1))) + (3.25 * size2)) *)\nlet cost_N_IOpen_chest size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.sub size1 (S.safe_int 1) * S.safe_int 22528)\n + (size2 lsr 2)\n + (size2 * S.safe_int 3)\n + S.safe_int 919000\n\n(* model interpreter/N_IOpen_chest_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10\n ((15.4181598756 + (0.25261512656 * (sub size1 1))) +\n (0.500643059623 * size2)) *)\nlet cost_N_IOpen_chest_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 (S.safe_int 1) in\n (w1 lsr 2) + (w1 lsr 7) + (size2 lsr 1) + (size2 lsr 6) + S.safe_int 15\n\n(* model interpreter/N_IOpen_chest_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = (919000. + (22528. * (sub size1 1))) + (3.25 * size2) in\n let alloc =\n (15.4181598756 + (0.25261512656 * (sub size1 1))) +\n (0.500643059623 * size2) in\n max 10 (max time alloc) *)\nlet cost_N_IOpen_chest_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.sub size1 (S.safe_int 1) in\n S.max\n ((w1 * S.safe_int 22528)\n + (size2 lsr 2)\n + (size2 * S.safe_int 3)\n + S.safe_int 919000)\n ((w1 lsr 2) + (w1 lsr 7) + (size2 lsr 1) + (size2 lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_IOpt_map *)\n(* max 10 (max 10. 0.) *)\nlet cost_N_IOpt_map = S.safe_int 10\n\n(* model interpreter/N_IOpt_map_none *)\n(* max 10 10. *)\nlet cost_N_IOpt_map_none = S.safe_int 10\n\n(* model interpreter/N_IOpt_map_none_alloc *)\n(* max 10 0. *)\nlet cost_N_IOpt_map_none_alloc = S.safe_int 10\n\n(* model interpreter/N_IOpt_map_none_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IOpt_map_none_synthesized = S.safe_int 10\n\n(* model interpreter/N_IOpt_map_some *)\n(* max 10 0. *)\nlet cost_N_IOpt_map_some = S.safe_int 10\n\n(* model interpreter/N_IOpt_map_some_alloc *)\n(* max 10 0. *)\nlet cost_N_IOpt_map_some_alloc = S.safe_int 10\n\n(* model interpreter/N_IOpt_map_some_synthesized *)\n(* let time = 0. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IOpt_map_some_synthesized = S.safe_int 10\n\n(* model interpreter/N_IOr *)\n(* max 10 10. *)\nlet cost_N_IOr = S.safe_int 10\n\n(* model interpreter/N_IOr_alloc *)\n(* max 10 0. *)\nlet cost_N_IOr_alloc = S.safe_int 10\n\n(* model interpreter/N_IOr_bytes *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IOr_bytes size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IOr_bytes_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (10.6873582322 + (0.499979321651 * (max size1 size2))) *)\nlet cost_N_IOr_bytes_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 15\n\n(* model interpreter/N_IOr_bytes_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 10.6873582322 + (0.499979321651 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IOr_bytes_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IOr_nat *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IOr_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IOr_nat_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (13.9478780796 + (0.500186338819 * (max size1 size2))) *)\nlet cost_N_IOr_nat_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 15\n\n(* model interpreter/N_IOr_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 13.9478780796 + (0.500186338819 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IOr_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_IOr_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IOr_synthesized = S.safe_int 10\n\n(* model interpreter/N_IPairing_check_bls12_381 *)\n(* fun size -> max 10 (450000. + (342500. * size)) *)\nlet cost_N_IPairing_check_bls12_381 size =\n let size = S.safe_int size in\n (size * S.safe_int 344064) + S.safe_int 450000\n\n(* model interpreter/N_IPairing_check_bls12_381_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_IPairing_check_bls12_381_alloc _size = S.safe_int 10\n\n(* model interpreter/N_IPairing_check_bls12_381_synthesized *)\n(* fun size ->\n let time = 450000. + (342500. * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IPairing_check_bls12_381_synthesized size =\n let size = S.safe_int size in\n (size * S.safe_int 344064) + S.safe_int 450000\n\n(* model interpreter/N_IPush *)\n(* max 10 10. *)\nlet cost_N_IPush = S.safe_int 10\n\n(* model interpreter/N_IPush_alloc *)\n(* max 10 12. *)\nlet cost_N_IPush_alloc = S.safe_int 15\n\n(* model interpreter/N_IPush_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IPush_synthesized = S.safe_int 15\n\n(* model interpreter/N_IRead_ticket *)\n(* max 10 10. *)\nlet cost_N_IRead_ticket = S.safe_int 10\n\n(* model interpreter/N_IRead_ticket_alloc *)\n(* max 10 56. *)\nlet cost_N_IRead_ticket_alloc = S.safe_int 60\n\n(* model interpreter/N_IRead_ticket_synthesized *)\n(* let time = 10. in let alloc = 56. in max 10 (max time alloc) *)\nlet cost_N_IRead_ticket_synthesized = S.safe_int 60\n\n(* model interpreter/N_IRight *)\n(* max 10 10. *)\nlet cost_N_IRight = S.safe_int 10\n\n(* model interpreter/N_IRight_alloc *)\n(* max 10 8. *)\nlet cost_N_IRight_alloc = S.safe_int 10\n\n(* model interpreter/N_IRight_synthesized *)\n(* let time = 10. in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_IRight_synthesized = S.safe_int 10\n\n(* model interpreter/N_ISapling_empty_state *)\n(* max 10 300. *)\nlet cost_N_ISapling_empty_state = S.safe_int 300\n\n(* model interpreter/N_ISapling_empty_state_alloc *)\n(* max 10 28. *)\nlet cost_N_ISapling_empty_state_alloc = S.safe_int 30\n\n(* model interpreter/N_ISapling_empty_state_synthesized *)\n(* let time = 300. in let alloc = 28. in max 10 (max time alloc) *)\nlet cost_N_ISapling_empty_state_synthesized = S.safe_int 300\n\n(* model interpreter/N_ISapling_verify_update *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((432500. + (5740000. * size1)) + (4636500. * size2)) *)\nlet cost_N_ISapling_verify_update size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (size1 * S.safe_int 5767168)\n + (size2 * S.safe_int 4718592)\n + S.safe_int 432500\n\n(* model interpreter/N_ISapling_verify_update_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((50.74 + (12.0173040271 * size1)) + (24.0179324276 * size2)) *)\nlet cost_N_ISapling_verify_update_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (size1 lsr 2) + (size2 lsr 1)\n + (size1 * S.safe_int 12)\n + (size2 * S.safe_int 24)\n + S.safe_int 55\n\n(* model interpreter/N_ISapling_verify_update_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = (432500. + (5740000. * size1)) + (4636500. * size2) in\n let alloc =\n (50.74 + (12.0173040271 * size1)) + (24.0179324276 * size2) in\n max 10 (max time alloc) *)\nlet cost_N_ISapling_verify_update_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n S.max\n ((size1 * S.safe_int 5767168)\n + (size2 * S.safe_int 4718592)\n + S.safe_int 432500)\n ((size1 lsr 2) + (size2 lsr 1)\n + (size1 * S.safe_int 12)\n + (size2 * S.safe_int 24)\n + S.safe_int 55)\n\n(* model interpreter/N_ISelf *)\n(* max 10 10. *)\nlet cost_N_ISelf = S.safe_int 10\n\n(* model interpreter/N_ISelf_address *)\n(* max 10 10. *)\nlet cost_N_ISelf_address = S.safe_int 10\n\n(* model interpreter/N_ISelf_address_alloc *)\n(* max 10 64. *)\nlet cost_N_ISelf_address_alloc = S.safe_int 65\n\n(* model interpreter/N_ISelf_address_synthesized *)\n(* let time = 10. in let alloc = 64. in max 10 (max time alloc) *)\nlet cost_N_ISelf_address_synthesized = S.safe_int 65\n\n(* model interpreter/N_ISelf_alloc *)\n(* max 10 52. *)\nlet cost_N_ISelf_alloc = S.safe_int 55\n\n(* model interpreter/N_ISelf_synthesized *)\n(* let time = 10. in let alloc = 52. in max 10 (max time alloc) *)\nlet cost_N_ISelf_synthesized = S.safe_int 55\n\n(* model interpreter/N_ISender *)\n(* max 10 10. *)\nlet cost_N_ISender = S.safe_int 10\n\n(* model interpreter/N_ISender_alloc *)\n(* max 10 72. *)\nlet cost_N_ISender_alloc = S.safe_int 75\n\n(* model interpreter/N_ISender_synthesized *)\n(* let time = 10. in let alloc = 72. in max 10 (max time alloc) *)\nlet cost_N_ISender_synthesized = S.safe_int 75\n\n(* model interpreter/N_ISet_delegate *)\n(* max 10 60. *)\nlet cost_N_ISet_delegate = S.safe_int 60\n\n(* model interpreter/N_ISet_delegate_alloc *)\n(* max 10 76. *)\nlet cost_N_ISet_delegate_alloc = S.safe_int 80\n\n(* model interpreter/N_ISet_delegate_synthesized *)\n(* let time = 60. in let alloc = 76. in max 10 (max time alloc) *)\nlet cost_N_ISet_delegate_synthesized = S.safe_int 80\n\n(* model interpreter/N_ISet_iter *)\n(* fun size -> max 10 (50. + (7.625 * size)) *)\nlet cost_N_ISet_iter size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 3) + (size * S.safe_int 7) + S.safe_int 50\n\n(* model interpreter/N_ISet_iter_alloc *)\n(* fun size -> max 10 0. *)\nlet cost_N_ISet_iter_alloc _size = S.safe_int 10\n\n(* model interpreter/N_ISet_iter_synthesized *)\n(* fun size ->\n let time = 50. + (7.625 * size) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ISet_iter_synthesized size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 3) + (size * S.safe_int 7) + S.safe_int 50\n\n(* model interpreter/N_ISet_mem *)\n(* fun size1 ->\n fun size2 ->\n max 10\n (39.3805426747 + (0.0564536354586 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_ISet_mem size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 5) + (w3 lsr 6) + (w3 lsr 7) + (w3 lsr 9) + S.safe_int 40\n\n(* model interpreter/N_ISet_mem_alloc *)\n(* fun size1 -> fun size2 -> max 10 0. *)\nlet cost_N_ISet_mem_alloc _size1 _size2 = S.safe_int 10\n\n(* model interpreter/N_ISet_mem_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n 39.3805426747 + (0.0564536354586 * (size1 * (log2 (1 + size2)))) in\n let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ISet_mem_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 5) + (w3 lsr 6) + (w3 lsr 7) + (w3 lsr 9) + S.safe_int 40\n\n(* model interpreter/N_ISet_size *)\n(* max 10 10. *)\nlet cost_N_ISet_size = S.safe_int 10\n\n(* model interpreter/N_ISet_size_alloc *)\n(* max 10 0. *)\nlet cost_N_ISet_size_alloc = S.safe_int 10\n\n(* model interpreter/N_ISet_size_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_ISet_size_synthesized = S.safe_int 10\n\n(* model interpreter/N_ISet_update *)\n(* fun size1 ->\n fun size2 ->\n max 10\n (49.8905426747 + (0.140036207663 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_ISet_update size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n (w3 lsr 3) + (w3 lsr 6) + S.safe_int 50\n\n(* model interpreter/N_ISet_update_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((21.7417458006 * (log2 (1 + size2))) + 77.6256737848) *)\nlet cost_N_ISet_update_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n (log2 (size2 + S.safe_int 1) * S.safe_int 22) + S.safe_int 80\n\n(* model interpreter/N_ISet_update_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time =\n 49.8905426747 + (0.140036207663 * (size1 * (log2 (1 + size2)))) in\n let alloc = (21.7417458006 * (log2 (1 + size2))) + 77.6256737848 in\n max 10 (max time alloc) *)\nlet cost_N_ISet_update_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n let w3 = w1 * size1 in\n S.max\n ((w3 lsr 3) + (w3 lsr 6) + S.safe_int 50)\n ((w1 * S.safe_int 22) + S.safe_int 80)\n\n(* model interpreter/N_ISha256 *)\n(* fun size -> max 10 (600. + (4.75 * size)) *)\nlet cost_N_ISha256 size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 2) + (size * S.safe_int 4) + S.safe_int 600\n\n(* model interpreter/N_ISha256_alloc *)\n(* fun size -> max 10 24. *)\nlet cost_N_ISha256_alloc _size = S.safe_int 25\n\n(* model interpreter/N_ISha256_synthesized *)\n(* fun size ->\n let time = 600. + (4.75 * size) in\n let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_ISha256_synthesized size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 2) + (size * S.safe_int 4) + S.safe_int 600\n\n(* model interpreter/N_ISha3 *)\n(* fun size -> max 10 (1350. + (8.25 * size)) *)\nlet cost_N_ISha3 size =\n let size = S.safe_int size in\n (size lsr 2) + (size * S.safe_int 8) + S.safe_int 1350\n\n(* model interpreter/N_ISha3_alloc *)\n(* fun size -> max 10 24. *)\nlet cost_N_ISha3_alloc _size = S.safe_int 25\n\n(* model interpreter/N_ISha3_synthesized *)\n(* fun size ->\n let time = 1350. + (8.25 * size) in\n let alloc = 24. in max 10 (max time alloc) *)\nlet cost_N_ISha3_synthesized size =\n let size = S.safe_int size in\n (size lsr 2) + (size * S.safe_int 8) + S.safe_int 1350\n\n(* model interpreter/N_ISha512 *)\n(* fun size -> max 10 (680. + (3. * size)) *)\nlet cost_N_ISha512 size =\n let size = S.safe_int size in\n (size * S.safe_int 3) + S.safe_int 680\n\n(* model interpreter/N_ISha512_alloc *)\n(* fun size -> max 10 40. *)\nlet cost_N_ISha512_alloc _size = S.safe_int 40\n\n(* model interpreter/N_ISha512_synthesized *)\n(* fun size ->\n let time = 680. + (3. * size) in\n let alloc = 40. in max 10 (max time alloc) *)\nlet cost_N_ISha512_synthesized size =\n let size = S.safe_int size in\n (size * S.safe_int 3) + S.safe_int 680\n\n(* model interpreter/N_ISlice_bytes *)\n(* fun size -> max 10 (25. + (0.5 * size)) *)\nlet cost_N_ISlice_bytes size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 25\n\n(* model interpreter/N_ISlice_bytes_alloc *)\n(* fun size -> max 10 (14.6142328624 + (0.500160203859 * size)) *)\nlet cost_N_ISlice_bytes_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 15\n\n(* model interpreter/N_ISlice_bytes_synthesized *)\n(* fun size ->\n let time = 25. + (0.5 * size) in\n let alloc = 14.6142328624 + (0.500160203859 * size) in\n max 10 (max time alloc) *)\nlet cost_N_ISlice_bytes_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 25) (w1 + (size lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_ISlice_string *)\n(* fun size -> max 10 (25. + (0.5 * size)) *)\nlet cost_N_ISlice_string size =\n let size = S.safe_int size in\n (size lsr 1) + S.safe_int 25\n\n(* model interpreter/N_ISlice_string_alloc *)\n(* fun size -> max 10 (15.686099896 + (0.500163489638 * size)) *)\nlet cost_N_ISlice_string_alloc size =\n let size = S.safe_int size in\n (size lsr 1) + (size lsr 6) + S.safe_int 20\n\n(* model interpreter/N_ISlice_string_synthesized *)\n(* fun size ->\n let time = 25. + (0.5 * size) in\n let alloc = 15.686099896 + (0.500163489638 * size) in\n max 10 (max time alloc) *)\nlet cost_N_ISlice_string_synthesized size =\n let size = S.safe_int size in\n let w1 = size lsr 1 in\n S.max (w1 + S.safe_int 25) (w1 + (size lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_ISource *)\n(* max 10 10. *)\nlet cost_N_ISource = S.safe_int 10\n\n(* model interpreter/N_ISource_alloc *)\n(* max 10 72. *)\nlet cost_N_ISource_alloc = S.safe_int 75\n\n(* model interpreter/N_ISource_synthesized *)\n(* let time = 10. in let alloc = 72. in max 10 (max time alloc) *)\nlet cost_N_ISource_synthesized = S.safe_int 75\n\n(* model interpreter/N_ISplit_ticket *)\n(* fun size1 -> fun size2 -> max 10 (40. + (0.5 * (max size1 size2))) *)\nlet cost_N_ISplit_ticket size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 40\n\n(* model interpreter/N_ISplit_ticket_alloc *)\n(* fun size1 -> fun size2 -> max 10 52. *)\nlet cost_N_ISplit_ticket_alloc _size1 _size2 = S.safe_int 55\n\n(* model interpreter/N_ISplit_ticket_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 40. + (0.5 * (max size1 size2)) in\n let alloc = 52. in max 10 (max time alloc) *)\nlet cost_N_ISplit_ticket_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n S.max ((S.max size1 size2 lsr 1) + S.safe_int 40) (S.safe_int 55)\n\n(* model interpreter/N_IString_size *)\n(* max 10 15. *)\nlet cost_N_IString_size = S.safe_int 15\n\n(* model interpreter/N_IString_size_alloc *)\n(* max 10 0. *)\nlet cost_N_IString_size_alloc = S.safe_int 10\n\n(* model interpreter/N_IString_size_synthesized *)\n(* let time = 15. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IString_size_synthesized = S.safe_int 15\n\n(* model interpreter/N_ISub_int *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_ISub_int size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_ISub_int_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (17.5501373306 + (0.500211925836 * (max size1 size2))) *)\nlet cost_N_ISub_int_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_ISub_int_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 17.5501373306 + (0.500211925836 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_ISub_int_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_ISub_tez *)\n(* max 10 15. *)\nlet cost_N_ISub_tez = S.safe_int 15\n\n(* model interpreter/N_ISub_tez_alloc *)\n(* max 10 20. *)\nlet cost_N_ISub_tez_alloc = S.safe_int 20\n\n(* model interpreter/N_ISub_tez_legacy *)\n(* max 10 20. *)\nlet cost_N_ISub_tez_legacy = S.safe_int 20\n\n(* model interpreter/N_ISub_tez_legacy_alloc *)\n(* max 10 12. *)\nlet cost_N_ISub_tez_legacy_alloc = S.safe_int 15\n\n(* model interpreter/N_ISub_tez_legacy_synthesized *)\n(* let time = 20. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_ISub_tez_legacy_synthesized = S.safe_int 20\n\n(* model interpreter/N_ISub_tez_synthesized *)\n(* let time = 15. in let alloc = 20. in max 10 (max time alloc) *)\nlet cost_N_ISub_tez_synthesized = S.safe_int 20\n\n(* model interpreter/N_ISub_timestamp_seconds *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_ISub_timestamp_seconds size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_ISub_timestamp_seconds_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (17.5501373306 + (0.500211925836 * (max size1 size2))) *)\nlet cost_N_ISub_timestamp_seconds_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 20\n\n(* model interpreter/N_ISub_timestamp_seconds_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 17.5501373306 + (0.500211925836 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_ISub_timestamp_seconds_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 20)\n\n(* model interpreter/N_ISwap *)\n(* max 10 10. *)\nlet cost_N_ISwap = S.safe_int 10\n\n(* model interpreter/N_ISwap_alloc *)\n(* max 10 12. *)\nlet cost_N_ISwap_alloc = S.safe_int 15\n\n(* model interpreter/N_ISwap_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_ISwap_synthesized = S.safe_int 15\n\n(* model interpreter/N_ITicket *)\n(* max 10 10. *)\nlet cost_N_ITicket = S.safe_int 10\n\n(* model interpreter/N_ITicket_alloc *)\n(* max 10 56. *)\nlet cost_N_ITicket_alloc = S.safe_int 60\n\n(* model interpreter/N_ITicket_synthesized *)\n(* let time = 10. in let alloc = 56. in max 10 (max time alloc) *)\nlet cost_N_ITicket_synthesized = S.safe_int 60\n\n(* model interpreter/N_ITotal_voting_power *)\n(* max 10 450. *)\nlet cost_N_ITotal_voting_power = S.safe_int 450\n\n(* model interpreter/N_ITotal_voting_power_alloc *)\n(* max 10 12. *)\nlet cost_N_ITotal_voting_power_alloc = S.safe_int 15\n\n(* model interpreter/N_ITotal_voting_power_synthesized *)\n(* let time = 450. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_ITotal_voting_power_synthesized = S.safe_int 450\n\n(* model interpreter/N_ITransfer_tokens_alloc *)\n(* max 10 120. *)\nlet cost_N_ITransfer_tokens_alloc = S.safe_int 120\n\n(* model interpreter/N_ITransfer_tokens_synthesized *)\n(* let time = 60. in let alloc = 120. in max 10 (max time alloc) *)\nlet cost_N_ITransfer_tokens_synthesized = S.safe_int 120\n\n(* model interpreter/N_IUncomb *)\n(* fun size -> max 10 (30. + (4. * (sub size 2))) *)\nlet cost_N_IUncomb size =\n let size = S.safe_int size in\n (S.sub size (S.safe_int 2) * S.safe_int 4) + S.safe_int 30\n\n(* model interpreter/N_IUncomb_alloc *)\n(* fun size -> max 10 (6.30950568452 + (11.9815614243 * size)) *)\nlet cost_N_IUncomb_alloc size =\n let size = S.safe_int size in\n (size * S.safe_int 12) + S.safe_int 10\n\n(* model interpreter/N_IUncomb_synthesized *)\n(* fun size ->\n let time = 30. + (4. * (sub size 2)) in\n let alloc = 6.30950568452 + (11.9815614243 * size) in\n max 10 (max time alloc) *)\nlet cost_N_IUncomb_synthesized size =\n let size = S.safe_int size in\n S.max\n ((S.sub size (S.safe_int 2) * S.safe_int 4) + S.safe_int 30)\n ((size * S.safe_int 12) + S.safe_int 10)\n\n(* model interpreter/N_IUnit *)\n(* max 10 10. *)\nlet cost_N_IUnit = S.safe_int 10\n\n(* model interpreter/N_IUnit_alloc *)\n(* max 10 12. *)\nlet cost_N_IUnit_alloc = S.safe_int 15\n\n(* model interpreter/N_IUnit_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IUnit_synthesized = S.safe_int 15\n\n(* model interpreter/N_IUnpack_alloc *)\n(* max 10 8. *)\nlet cost_N_IUnpack_alloc = S.safe_int 10\n\n(* model interpreter/N_IUnpack_synthesized *)\n(* let time = 278.760542675 in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_IUnpack_synthesized = S.safe_int 280\n\n(* model interpreter/N_IUnpair *)\n(* max 10 10. *)\nlet cost_N_IUnpair = S.safe_int 10\n\n(* model interpreter/N_IUnpair_alloc *)\n(* max 10 12. *)\nlet cost_N_IUnpair_alloc = S.safe_int 15\n\n(* model interpreter/N_IUnpair_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_IUnpair_synthesized = S.safe_int 15\n\n(* model interpreter/N_IView *)\n(* max 10 1460. *)\nlet cost_N_IView = S.safe_int 1460\n\n(* model interpreter/N_IView_alloc *)\n(* max 10 0. *)\nlet cost_N_IView_alloc = S.safe_int 10\n\n(* model interpreter/N_IView_synthesized *)\n(* let time = 1460. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IView_synthesized = S.safe_int 1460\n\n(* model interpreter/N_IVoting_power *)\n(* max 10 640. *)\nlet cost_N_IVoting_power = S.safe_int 640\n\n(* model interpreter/N_IVoting_power_alloc *)\n(* max 10 0. *)\nlet cost_N_IVoting_power_alloc = S.safe_int 10\n\n(* model interpreter/N_IVoting_power_synthesized *)\n(* let time = 640. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IVoting_power_synthesized = S.safe_int 640\n\n(* model interpreter/N_IXor *)\n(* max 10 15. *)\nlet cost_N_IXor = S.safe_int 15\n\n(* model interpreter/N_IXor_alloc *)\n(* max 10 0. *)\nlet cost_N_IXor_alloc = S.safe_int 10\n\n(* model interpreter/N_IXor_bytes *)\n(* fun size1 -> fun size2 -> max 10 (40. + (0.5 * (max size1 size2))) *)\nlet cost_N_IXor_bytes size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 40\n\n(* model interpreter/N_IXor_bytes_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (10.6873582322 + (0.499979321651 * (max size1 size2))) *)\nlet cost_N_IXor_bytes_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 15\n\n(* model interpreter/N_IXor_bytes_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 40. + (0.5 * (max size1 size2)) in\n let alloc = 10.6873582322 + (0.499979321651 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IXor_bytes_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 40\n\n(* model interpreter/N_IXor_nat *)\n(* fun size1 -> fun size2 -> max 10 (35. + (0.5 * (max size1 size2))) *)\nlet cost_N_IXor_nat size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (S.max size1 size2 lsr 1) + S.safe_int 35\n\n(* model interpreter/N_IXor_nat_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 (13.9478780796 + (0.500186338819 * (max size1 size2))) *)\nlet cost_N_IXor_nat_alloc size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n (w1 lsr 1) + (w1 lsr 6) + S.safe_int 15\n\n(* model interpreter/N_IXor_nat_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 35. + (0.5 * (max size1 size2)) in\n let alloc = 13.9478780796 + (0.500186338819 * (max size1 size2)) in\n max 10 (max time alloc) *)\nlet cost_N_IXor_nat_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = S.max size1 size2 in\n let w2 = w1 lsr 1 in\n S.max (w2 + S.safe_int 35) (w2 + (w1 lsr 6) + S.safe_int 15)\n\n(* model interpreter/N_IXor_synthesized *)\n(* let time = 15. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_IXor_synthesized = S.safe_int 15\n\n(* model interpreter/N_KCons *)\n(* max 10 10. *)\nlet cost_N_KCons = S.safe_int 10\n\n(* model interpreter/N_KCons_alloc *)\n(* max 10 0. *)\nlet cost_N_KCons_alloc = S.safe_int 10\n\n(* model interpreter/N_KCons_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KCons_synthesized = S.safe_int 10\n\n(* model interpreter/N_KIter *)\n(* max 10 (max 10. 10.) *)\nlet cost_N_KIter = S.safe_int 10\n\n(* model interpreter/N_KIter_empty *)\n(* max 10 10. *)\nlet cost_N_KIter_empty = S.safe_int 10\n\n(* model interpreter/N_KIter_empty_alloc *)\n(* max 10 0. *)\nlet cost_N_KIter_empty_alloc = S.safe_int 10\n\n(* model interpreter/N_KIter_empty_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KIter_empty_synthesized = S.safe_int 10\n\n(* model interpreter/N_KIter_nonempty *)\n(* max 10 10. *)\nlet cost_N_KIter_nonempty = S.safe_int 10\n\n(* model interpreter/N_KIter_nonempty_alloc *)\n(* max 10 0. *)\nlet cost_N_KIter_nonempty_alloc = S.safe_int 10\n\n(* model interpreter/N_KIter_nonempty_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KIter_nonempty_synthesized = S.safe_int 10\n\n(* model interpreter/N_KList_enter_body_alloc *)\n(* fun size_xs ->\n fun size_ys ->\n max 10 (if size_xs = 0 then 23. + (12.0014700944 * size_ys) else 0.) *)\nlet cost_N_KList_enter_body_alloc size_xs size_ys =\n let size_xs = S.safe_int size_xs in\n let size_ys = S.safe_int size_ys in\n S.max\n (S.safe_int 10)\n (if size_xs = S.safe_int 0 then\n (size_ys lsr 2) + (size_ys * S.safe_int 12) + S.safe_int 25\n else S.safe_int 0)\n\n(* model interpreter/N_KList_enter_body_synthesized *)\n(* fun size_xs ->\n fun size_ys ->\n let time = if size_xs = 0 then 30. + (1.8125 * size_ys) else 30. in\n let alloc =\n if size_xs = 0 then 23. + (12.0014700944 * size_ys) else 0. in\n max 10 (max time alloc) *)\nlet cost_N_KList_enter_body_synthesized size_xs size_ys =\n let size_xs = S.safe_int size_xs in\n let size_ys = S.safe_int size_ys in\n let w1 = size_ys lsr 2 in\n let w2 = size_xs = S.safe_int 0 in\n S.max\n (S.max\n (S.safe_int 10)\n (if w2 then\n (size_ys lsr 1) + w1 + (size_ys lsr 4) + size_ys + S.safe_int 30\n else S.safe_int 30))\n (if w2 then w1 + (size_ys * S.safe_int 12) + S.safe_int 25\n else S.safe_int 0)\n\n(* model interpreter/N_KList_exit_body *)\n(* max 10 10. *)\nlet cost_N_KList_exit_body = S.safe_int 10\n\n(* model interpreter/N_KList_exit_body_alloc *)\n(* max 10 0. *)\nlet cost_N_KList_exit_body_alloc = S.safe_int 10\n\n(* model interpreter/N_KList_exit_body_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KList_exit_body_synthesized = S.safe_int 10\n\n(* model interpreter/N_KLoop_in *)\n(* max 10 10. *)\nlet cost_N_KLoop_in = S.safe_int 10\n\n(* model interpreter/N_KLoop_in_alloc *)\n(* max 10 0. *)\nlet cost_N_KLoop_in_alloc = S.safe_int 10\n\n(* model interpreter/N_KLoop_in_left *)\n(* max 10 10. *)\nlet cost_N_KLoop_in_left = S.safe_int 10\n\n(* model interpreter/N_KLoop_in_left_alloc *)\n(* max 10 0. *)\nlet cost_N_KLoop_in_left_alloc = S.safe_int 10\n\n(* model interpreter/N_KLoop_in_left_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KLoop_in_left_synthesized = S.safe_int 10\n\n(* model interpreter/N_KLoop_in_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KLoop_in_synthesized = S.safe_int 10\n\n(* model interpreter/N_KMap_enter_body_alloc *)\n(* fun size -> max 10 (if size = 0 then 11. else 0.) *)\nlet cost_N_KMap_enter_body_alloc size =\n let size = S.safe_int size in\n S.max\n (S.safe_int 10)\n (if size = S.safe_int 0 then S.safe_int 15 else S.safe_int 0)\n\n(* model interpreter/N_KMap_enter_body_synthesized *)\n(* fun size ->\n let time = if size = 0 then 10. else 80. in\n let alloc = if size = 0 then 11. else 0. in max 10 (max time alloc) *)\nlet cost_N_KMap_enter_body_synthesized size =\n let size = S.safe_int size in\n let w1 = size = S.safe_int 0 in\n S.max\n (S.max (S.safe_int 10) (if w1 then S.safe_int 10 else S.safe_int 80))\n (if w1 then S.safe_int 15 else S.safe_int 0)\n\n(* model interpreter/N_KMap_exit_body *)\n(* fun size1 ->\n fun size2 ->\n max 10 (0. + (0.114964427843 * (size1 * (log2 (1 + size2))))) *)\nlet cost_N_KMap_exit_body size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w3 = log2 (size2 + S.safe_int 1) * size1 in\n S.max\n (S.safe_int 10)\n ((w3 lsr 4) + (w3 lsr 5) + (w3 lsr 6) + (w3 lsr 8) + (w3 lsr 9))\n\n(* model interpreter/N_KMap_exit_body_alloc *)\n(* fun size1 ->\n fun size2 ->\n max 10 ((28.3877828935 * (log2 (1 + size2))) + 74.4085101791) *)\nlet cost_N_KMap_exit_body_alloc _size1 size2 =\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n (w1 * S.safe_int 28) + (w1 lsr 1) + S.safe_int 75\n\n(* model interpreter/N_KMap_exit_body_synthesized *)\n(* fun size1 ->\n fun size2 ->\n let time = 0. + (0.114964427843 * (size1 * (log2 (1 + size2)))) in\n let alloc = (28.3877828935 * (log2 (1 + size2))) + 74.4085101791 in\n max 10 (max time alloc) *)\nlet cost_N_KMap_exit_body_synthesized size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let w1 = log2 (size2 + S.safe_int 1) in\n let w3 = w1 * size1 in\n S.max\n ((w3 lsr 4) + (w3 lsr 5) + (w3 lsr 6) + (w3 lsr 8) + (w3 lsr 9))\n ((w1 * S.safe_int 28) + (w1 lsr 1) + S.safe_int 75)\n\n(* model interpreter/N_KMap_head *)\n(* max 10 20. *)\nlet cost_N_KMap_head = S.safe_int 20\n\n(* model interpreter/N_KMap_head_alloc *)\n(* max 10 8. *)\nlet cost_N_KMap_head_alloc = S.safe_int 10\n\n(* model interpreter/N_KMap_head_synthesized *)\n(* let time = 20. in let alloc = 8. in max 10 (max time alloc) *)\nlet cost_N_KMap_head_synthesized = S.safe_int 20\n\n(* model interpreter/N_KNil *)\n(* max 10 15. *)\nlet cost_N_KNil = S.safe_int 15\n\n(* model interpreter/N_KNil_alloc *)\n(* max 10 0. *)\nlet cost_N_KNil_alloc = S.safe_int 10\n\n(* model interpreter/N_KNil_synthesized *)\n(* let time = 15. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KNil_synthesized = S.safe_int 15\n\n(* model interpreter/N_KReturn *)\n(* max 10 10. *)\nlet cost_N_KReturn = S.safe_int 10\n\n(* model interpreter/N_KReturn_alloc *)\n(* max 10 0. *)\nlet cost_N_KReturn_alloc = S.safe_int 10\n\n(* model interpreter/N_KReturn_synthesized *)\n(* let time = 10. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KReturn_synthesized = S.safe_int 10\n\n(* model interpreter/N_KUndip *)\n(* max 10 10. *)\nlet cost_N_KUndip = S.safe_int 10\n\n(* model interpreter/N_KUndip_alloc *)\n(* max 10 12. *)\nlet cost_N_KUndip_alloc = S.safe_int 15\n\n(* model interpreter/N_KUndip_synthesized *)\n(* let time = 10. in let alloc = 12. in max 10 (max time alloc) *)\nlet cost_N_KUndip_synthesized = S.safe_int 15\n\n(* model interpreter/N_KView_exit *)\n(* max 10 20. *)\nlet cost_N_KView_exit = S.safe_int 20\n\n(* model interpreter/N_KView_exit_alloc *)\n(* max 10 0. *)\nlet cost_N_KView_exit_alloc = S.safe_int 10\n\n(* model interpreter/N_KView_exit_synthesized *)\n(* let time = 20. in let alloc = 0. in max 10 (max time alloc) *)\nlet cost_N_KView_exit_synthesized = S.safe_int 20\n\n(* model interpreter/amplification_loop_model *)\n(* fun size -> max 10 (0.329309341324 * size) *)\nlet cost_amplification_loop_model size =\n let size = S.safe_int size in\n S.max\n (S.safe_int 10)\n ((size lsr 2) + (size lsr 4) + (size lsr 6) + (size lsr 7))\n\n(* model translator/PARSE_TYPE *)\n(* fun size -> max 10 (0. + (60. * size)) *)\nlet cost_PARSE_TYPE size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 60)\n\n(* model translator/Parsing_Code_gas *)\n(* fun size -> max 10 (0. + (0.890391244567 * size)) *)\nlet cost_Parsing_Code_gas size =\n let size = S.safe_int size in\n S.max\n (S.safe_int 10)\n ((size lsr 1) + (size lsr 2) + (size lsr 3) + (size lsr 6))\n\n(* model translator/Parsing_Code_size *)\n(* fun size1 ->\n fun size2 ->\n fun size3 ->\n max 10 (((187.300458967 * size1) + (0. * size2)) + (0. * size3)) *)\nlet cost_Parsing_Code_size size1 _size2 _size3 =\n let size1 = S.safe_int size1 in\n S.max (S.safe_int 10) (size1 * S.safe_int 188)\n\n(* model translator/Parsing_Data_gas *)\n(* fun size -> max 10 (67277.397394 + (0.142972986751 * size)) *)\nlet cost_Parsing_Data_gas size =\n let size = S.safe_int size in\n (size lsr 3) + (size lsr 6) + (size lsr 8) + S.safe_int 67280\n\n(* model translator/Parsing_Data_size *)\n(* fun size1 ->\n fun size2 ->\n fun size3 ->\n max 10\n (((80.363444899 * size1) + (16.1426805777 * size2)) +\n (68.9487320686 * size3)) *)\nlet cost_Parsing_Data_size size1 size2 size3 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let size3 = S.safe_int size3 in\n S.max\n (S.safe_int 10)\n ((size2 lsr 1)\n + (size1 * S.safe_int 82)\n + (size2 * S.safe_int 16)\n + (size3 * S.safe_int 70))\n\n(* model translator/TY_EQ *)\n(* fun size -> max 10 (31.1882471167 + (21.8805791266 * size)) *)\nlet cost_TY_EQ size = (size * S.safe_int 22) + S.safe_int 35\n\n(* model translator/UNPARSE_TYPE *)\n(* fun size -> max 10 (0. + (20. * size)) *)\nlet cost_UNPARSE_TYPE size = S.max (S.safe_int 10) (size * S.safe_int 20)\n\n(* model translator/Unparsing_Code_gas *)\n(* fun size -> max 10 (0. + (0.592309924661 * size)) *)\nlet cost_Unparsing_Code_gas size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) ((size lsr 1) + (size lsr 4) + (size lsr 5))\n\n(* model translator/Unparsing_Code_size *)\n(* fun size1 ->\n fun size2 ->\n fun size3 ->\n max 10 (((124.72642512 * size1) + (0. * size2)) + (0. * size3)) *)\nlet cost_Unparsing_Code_size size1 _size2 _size3 =\n let size1 = S.safe_int size1 in\n S.max (S.safe_int 10) (size1 * S.safe_int 126)\n\n(* model translator/Unparsing_Data_gas *)\n(* fun size -> max 10 (31944.7865384 + (0.033862305692 * size)) *)\nlet cost_Unparsing_Data_gas size =\n let size = S.safe_int size in\n (size lsr 5) + (size lsr 9) + (size lsr 10) + S.safe_int 31945\n\n(* model translator/Unparsing_Data_size *)\n(* fun size1 ->\n fun size2 ->\n fun size3 ->\n max 10 (((54.8706646933 * size1) + (0. * size2)) + (0. * size3)) *)\nlet cost_Unparsing_Data_size size1 _size2 _size3 =\n let size1 = S.safe_int size1 in\n S.max (S.safe_int 10) (size1 * S.safe_int 55)\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-2023 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(** Hand-edited/written cost functions *)\n\n(* Functions to be replaced by the generated code.\n\n The codegen cannot generate exactly the same code here. They have to\n be replaced by the generated versions.\n*)\n\n(* generated code is not usable: the const is not on a grid point *)\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(* generated code is not usable: the actual code and the model differ *)\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(* ------------------------------------------------------------------------ *)\n\n(* N_ISapling_verify_update_with_blake2b\n This function depends on another cost function cost_N_IBlake2b.\n Such code can't be generated by the current Snoop. *)\nlet cost_N_ISapling_verify_update_with_blake2b size1 size2 bound_data =\n let open S.Syntax in\n cost_N_IBlake2b bound_data + cost_N_ISapling_verify_update size1 size2\n\n(* N_IApply\n The current generated model receives int as a flag,\n but it should receive bool. *)\n(* model N_IApply *)\n(* fun size -> if (size = 0) then 140 else 220 *)\nlet cost_N_IApply rec_flag = if rec_flag then S.safe_int 220 else S.safe_int 140\n\n(* N_KMap_enter_body\n Removed conversion of [size] for optimization *)\n(* model N_KMap_enter_body *)\nlet cost_N_KMap_enter_body size =\n if Compare.Int.(size = 0) then S.safe_int 10 else 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(* 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(* 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_TYPE1 = cost_PARSE_TYPE 1\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(* ------------------------------------------------------------------------ *)\n\n(* These functions lack the corresponding models. *)\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\n(* ------------------------------------------------------------------------ *)\n\n(* IDropN and IDupN use non affine models with multiple cases. The inferred\n cost functions are more complex than the following affine functions. *)\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_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\n(* ------------------------------------------------------------------------ *)\n\n(* Following functions are partially carbonated: they charge some gas\n by themselves. Their inferred gas parameters cannot be directly\n used since they should contain the partial carbonation.\n*)\n\n(* model N_IContract *)\n(* Inferred value: 703.26072741 *)\n(* Most computation happens in [parse_contract_for_script], which is\n carbonated. *)\nlet cost_N_IContract = S.safe_int 30\n\n(* model N_ICreate_contract *)\n(* Inferred value: 814.154060743 *)\n(* Most computation happens in [create_contract], which is carbonated. *)\nlet cost_N_ICreate_contract = S.safe_int 60\n\n(* model N_ITransfer_tokens *)\n(* Inferred value: 230.707394077 *)\n(* Most computation happens in [transfer], which is carbonated. *)\nlet cost_N_ITransfer_tokens = S.safe_int 60\n\n(* model IEmit *)\n(* Inferred value: 244.687394077 *)\n(* Most computation happens in [emit_event], which is carbonated. *)\nlet cost_N_IEmit = S.safe_int 30\n\n(* --------------------------------------------------------------------- *)\n\n(* The cost functions below where not benchmarked, a cost model was derived\n from looking at similar instructions. *)\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\nlet cost_N_IConcat_string_precheck length =\n (* we set the precheck to be slightly more expensive than cost_N_IList_iter *)\n let open S.Syntax in\n let length = S.safe_int length in\n length * S.safe_int 10\n\n(* This is the cost of allocating a string and blitting existing ones into it. *)\nlet cost_N_IConcat_string total_bytes =\n let open S.Syntax in\n S.safe_int 100 + (total_bytes lsr 1)\n\n(* Same story as Concat_string. *)\nlet cost_N_IConcat_bytes total_bytes =\n let open S.Syntax in\n S.safe_int 100 + (total_bytes lsr 1)\n\n(* A partially carbonated instruction,\n so its model does not correspond to this function *)\n(* Cost of Unpack pays two integer comparisons, and a Bytes slice *)\nlet cost_N_IUnpack total_bytes =\n let open S.Syntax in\n let total_bytes = S.safe_int total_bytes in\n S.safe_int 260 + (total_bytes lsr 1)\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 module type of struct\n include Smart_rollup.Address\n end\n\n val of_b58data : Base58.data -> t option\n\n (** Prefix of smart rollup addresses in base58-check. *)\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 : module type of struct\n include Smart_rollup.State_hash\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 : sig\n include S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t\n\n (** Classic RPC argument with name [\"pkh\"]. *)\n val rpc_arg : t RPC_arg.t\n\n (** RPC argument with name [\"staker1_pkh\"]. *)\n val rpc_arg_staker1 : t RPC_arg.t\n\n (** RPC argument with name [\"staker2_pkh\"]. *)\n val rpc_arg_staker2 : t RPC_arg.t\nend\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 include Smart_rollup.Address\n\n let prefix = \"sr1\"\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix 36\n\n let of_b58data = function Smart_rollup.Address.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\nmodule State_hash = Smart_rollup.State_hash\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/5506\n Remove type and module aliases for Smart_rollup.Address. *)\n\ntype t = Address.t\n\nlet pp = Address.pp\n\nlet encoding = Address.encoding\n\nlet rpc_arg = Address.rpc_arg\n\nlet in_memory_size (_ : t) =\n let open Cache_memory_helpers in\n h1w +! string_size_gen Address.size\n\nmodule Staker = struct\n include Signature.Public_key_hash\n\n let rpc_arg_staker1 =\n RPC_arg.like rpc_arg ?descr:(RPC_arg.descr rpc_arg).descr \"staker1_pkh\"\n\n let rpc_arg_staker2 =\n RPC_arg.like rpc_arg ?descr:(RPC_arg.descr rpc_arg).descr \"staker2_pkh\"\nend\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_dal_parameters_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Marigold <contact@marigold.dev> *)\n(* *)\n(*****************************************************************************)\n\n(** DAL related parameters for the PVMs. *)\n\n(** DAL related parameters that would be useful to the kernel. These parameters are a\n subset of the DAL parametric constants defined in {!Constants_parametric_repr}.\n We use [int64] so they should be \"large enough\" to accommodate encoding changes\n of types in {!Constants_parametric_repr} *)\ntype t = {\n number_of_slots : int64;\n attestation_lag : int64;\n slot_size : int64;\n page_size : int64;\n}\n\n(** Pretty-printer for the parameters. *)\nval pp : Format.formatter -> t -> unit\n\n(** Equality of the parameters. *)\nval equal : t -> t -> bool\n\n(** Encoding of the parameters. *)\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Marigold <contact@marigold.dev> *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n number_of_slots : int64;\n attestation_lag : int64;\n slot_size : int64;\n page_size : int64;\n}\n\nlet pp ppf {number_of_slots; attestation_lag; slot_size; page_size} =\n Format.fprintf\n ppf\n \"number_of_slots: %Ld ; attestation_lag: %Ld ; slot_size: %Ld ; page_size: \\\n %Ld\"\n number_of_slots\n attestation_lag\n slot_size\n page_size\n\nlet equal t1 t2 =\n Compare.Int64.(\n t1.attestation_lag = t2.attestation_lag\n && t1.slot_size = t2.slot_size\n && t1.page_size = t2.page_size)\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {number_of_slots; attestation_lag; slot_size; page_size} ->\n (number_of_slots, attestation_lag, slot_size, page_size))\n (fun (number_of_slots, attestation_lag, slot_size, page_size) ->\n {number_of_slots; attestation_lag; slot_size; page_size})\n (obj4\n (req \"number_of_slots\" int64)\n (req \"attestation_lag\" int64)\n (req \"slot_size\" int64)\n (req \"page_size\" int64))\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 | Protocol_migration of string\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\n(** {!info_per_level_serialized ~predecessor_timestamp ~predecessor} is the serialized representation of the internal message for {!Info_per_level}. *)\nval info_per_level_serialized :\n predecessor_timestamp:Time.t -> predecessor:Block_hash.t -> 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 | Protocol_migration of string\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 case\n (Tag 4)\n ~title:\"Protocol_migration\"\n (obj2 (kind \"protocol_migration\") (req \"protocol\" (string Hex)))\n (function Protocol_migration proto -> Some ((), proto) | _ -> None)\n (fun ((), proto) -> Protocol_migration proto);\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 startup 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 startup time as we are defining a top-level value. *)\n Data_encoding.Binary.to_string_exn encoding (Internal End_of_level)\n\nlet info_per_level_serialized ~predecessor_timestamp ~predecessor =\n match\n serialize (Internal (Info_per_level {predecessor_timestamp; predecessor}))\n with\n | Error _ ->\n (* The info per level should always be serializable as the encoding\n functions for this case do not fail. *)\n assert false\n | Ok info -> info\n\nlet (_dummy_serialized_info_per_level_serialized : serialized) =\n (* This allows to detect an error, at startup, we might have introduced in the\n encoding of serialization of info per level messages . *)\n info_per_level_serialized\n ~predecessor_timestamp:(Time.of_seconds Int64.min_int)\n ~predecessor:Block_hash.zero\n" ;
} ;
{ name = "Sc_rollup_inbox_merkelized_payload_hashes_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2022 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype error += Merkelized_payload_hashes_proof_error of string\n\nmodule Hash : S.HASH with type t = Smart_rollup.Merkelized_payload_hashes_hash.t\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_no_history payload] is the initial merkelized payload hashes with\n index 0. *)\nval genesis_no_history : Sc_rollup_inbox_message_repr.serialized -> t\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_no_history merkelized payload] creates a new {!t} with [payload]\n and [merkelized] as ancestor (i.e. [index = succ (get_index\n merkelized)]). *)\nval add_payload_no_history : t -> Sc_rollup_inbox_message_repr.serialized -> t\n\n(** [add_payload] is identical to {!add_payload_no_history} but the resulting\n [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(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2022 Nomadic Labs, <contact@nomadic-labs.com> *)\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.Make (Skip_list_parameters)\nmodule Hash = Smart_rollup.Merkelized_payload_hashes_hash\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 fmt merkelized =\n Format.fprintf\n fmt\n \"@[<v>cell ptr: %a@,@[<v 2>cell content:@,%a@]@]\"\n Hash.pp_short\n (hash merkelized)\n (Skip_list.pp\n ~pp_content:Sc_rollup_inbox_message_repr.Hash.pp_short\n ~pp_ptr:Hash.pp_short)\n merkelized\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_no_history payload =\n let payload_hash =\n Sc_rollup_inbox_message_repr.hash_serialized_message payload\n in\n Skip_list.genesis payload_hash\n\nlet genesis history payload =\n let open Result_syntax in\n let merkelized = genesis_no_history payload in\n let+ history = remember history merkelized payload in\n (history, merkelized)\n\nlet add_payload_no_history prev_merkelized payload =\n let prev_merkelized_ptr = hash prev_merkelized in\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\nlet add_payload history prev_merkelized payload =\n let open Result_syntax in\n let merkelized = add_payload_no_history prev_merkelized payload 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 :: _ -> return cell\n | [] -> tzfail (Merkelized_payload_hashes_proof_error \"proof is empty\")\n in\n let rec aux (hash_map, ptr_list) = function\n | [] -> tzfail (Merkelized_payload_hashes_proof_error \"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 return (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 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_whitelist_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 = Signature.Public_key_hash.t list\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\n(** This type is used in the `Storage.Last_whitelist_update. It is the\n latest whitelist update message executed in the L1. It is used to\n prevent user to execute whitelist update in unchronological\n order. *)\ntype last_whitelist_update = {\n message_index : Z.t;\n outbox_level : Raw_level_repr.t;\n}\n\nval last_whitelist_update_encoding : last_whitelist_update Data_encoding.t\n\ntype update = Public | Private of t\n\nval update_encoding : update Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 = Signature.Public_key_hash.t list\n\nlet encoding =\n let open Data_encoding in\n (* The whitelist size is checked to forbid the origination of a\n whitelist that is bigger than any subsequent whitelist\n update. This check is valid because the binary outbox message\n encoding size is only two bytes longer than the maximum whitelist\n update size (encoded in binary), where the encoding of a key is\n 20 bytes long. *)\n check_size (Constants_repr.sc_rollup_message_size_limit - 2)\n @@ list Signature.Public_key_hash.encoding\n\nlet pp ppf =\n let open Format in\n fprintf\n ppf\n \"@[<hv>@[<hv 2>[@,%a@]@,]@]\"\n (pp_print_list\n ~pp_sep:(fun ppf () -> fprintf ppf \";@ \")\n Signature.Public_key_hash.pp_short)\n\ntype last_whitelist_update = {\n message_index : Z.t;\n outbox_level : Raw_level_repr.t;\n}\n\nlet last_whitelist_update_encoding =\n Data_encoding.(\n conv\n (fun {message_index; outbox_level} -> (message_index, outbox_level))\n (fun (message_index, outbox_level) -> {message_index; outbox_level})\n (obj2\n (req \"message_index\" n)\n (req \"outbox_level\" Raw_level_repr.encoding)))\n\ntype update = Public | Private of t\n\nlet update_encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Public\"\n (obj1 (req \"kind\" (constant \"public\")))\n (function Public -> Some () | _ -> None)\n (fun () -> Public);\n case\n (Tag 1)\n ~title:\"Private\"\n (obj2 (req \"kind\" (constant \"update\")) (req \"whitelist\" encoding))\n (function Private whitelist -> Some ((), whitelist) | _ -> None)\n (fun ((), whitelist) -> Private whitelist);\n ]\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 transaction from L2 to L1, with typed payload. *)\ntype typed_transaction = {\n unparsed_parameters : Script_repr.expr; (** The payload. *)\n unparsed_ty : Script_repr.expr; (** The type of 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 =\n | Atomic_transaction_batch of {transactions : transaction list}\n | Atomic_transaction_batch_typed of {transactions : typed_transaction list}\n | Whitelist_update of Sc_rollup_whitelist_repr.t option\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\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 pp_untyped_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 \"@[<2>destination: %a@, entrypoint: %a@, unparsed_parameters: %a@]\"\n Contract_hash.pp\n destination\n Entrypoint_repr.pp\n entrypoint\n Data_encoding.Json.pp\n json\n\ntype typed_transaction = {\n unparsed_parameters : Script_repr.expr;\n unparsed_ty : Script_repr.expr;\n destination : Contract_hash.t;\n entrypoint : Entrypoint_repr.t;\n}\n\nlet typed_transaction_encoding =\n let open Data_encoding in\n conv\n (fun {unparsed_parameters; unparsed_ty; destination; entrypoint} ->\n (unparsed_parameters, unparsed_ty, destination, entrypoint))\n (fun (unparsed_parameters, unparsed_ty, destination, entrypoint) ->\n {unparsed_parameters; unparsed_ty; destination; entrypoint})\n @@ obj4\n (req \"parameters\" Script_repr.expr_encoding)\n (req \"parameters_ty\" Script_repr.expr_encoding)\n (req \"destination\" Contract_repr.originated_encoding)\n Entrypoint_repr.(dft \"entrypoint\" simple_encoding default)\n\nlet pp_typed_transaction fmt\n {destination; entrypoint; unparsed_parameters; unparsed_ty} =\n let json_param =\n Data_encoding.Json.construct Script_repr.expr_encoding unparsed_parameters\n in\n let json_ty =\n Data_encoding.Json.construct Script_repr.expr_encoding unparsed_ty\n in\n Format.fprintf\n fmt\n \"@[<v2>destination: %a@,\\\n entrypoint: %a@,\\\n unparsed_ty: %a@,\\\n unparsed_parameters: %a@]\"\n Contract_hash.pp\n destination\n Entrypoint_repr.pp\n entrypoint\n Data_encoding.Json.pp\n json_ty\n Data_encoding.Json.pp\n json_param\n\ntype t =\n | Atomic_transaction_batch of {transactions : transaction list}\n | Atomic_transaction_batch_typed of {transactions : typed_transaction list}\n | Whitelist_update of Sc_rollup_whitelist_repr.t option\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 (obj2\n (req \"transactions\" (list transaction_encoding))\n (req \"kind\" (constant \"untyped\")))\n (function\n | Atomic_transaction_batch {transactions} -> Some (transactions, ())\n | _ -> None)\n (fun (transactions, ()) -> Atomic_transaction_batch {transactions});\n case\n (Tag 1)\n ~title:\"Atomic_transaction_batch_typed\"\n (obj2\n (req \"transactions\" (list typed_transaction_encoding))\n (req \"kind\" (constant \"typed\")))\n (function\n | Atomic_transaction_batch_typed {transactions} ->\n Some (transactions, ())\n | _ -> None)\n (fun (transactions, ()) ->\n Atomic_transaction_batch_typed {transactions});\n case\n (Tag 2)\n ~title:\"Whitelist_update\"\n (obj2\n (opt \"whitelist\" Sc_rollup_whitelist_repr.encoding)\n (req \"kind\" (constant \"whitelist_update\")))\n (function\n | Whitelist_update whitelist_opt -> Some (whitelist_opt, ())\n | _ -> None)\n (fun (whitelist_opt, ()) -> Whitelist_update whitelist_opt);\n ])\n\nlet pp fmt = function\n | Atomic_transaction_batch {transactions} ->\n Format.pp_print_list\n ~pp_sep:Format.pp_print_space\n pp_untyped_transaction\n fmt\n transactions\n | Atomic_transaction_batch_typed {transactions} ->\n Format.pp_print_list\n ~pp_sep:Format.pp_print_space\n pp_typed_transaction\n fmt\n transactions\n | Whitelist_update whitelist_opt ->\n Format.pp_print_option Sc_rollup_whitelist_repr.pp fmt whitelist_opt\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_unit\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 | Dal_parameters of Sc_rollup_dal_parameters_repr.t\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 | Dal_parameters dal_parameters ->\n Sc_rollup_dal_parameters_repr.pp fmt dal_parameters\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 kind name = req \"reveal_data_kind\" (constant name) in\n let case_raw_data =\n case\n ~title:\"raw data\"\n (Tag 0)\n (obj2\n (kind \"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 (kind \"metadata\") (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 (kind \"dal_page\") (req \"dal_page_content\" (option (bytes Hex))))\n (function Dal_page p -> Some ((), p) | _ -> None)\n (fun ((), p) -> Dal_page p)\n in\n let case_dal_parameters =\n case\n ~title:\"dal parameters\"\n (Tag 3)\n (obj2\n (kind \"dal_parameters\")\n (req \"dal_parameters\" Sc_rollup_dal_parameters_repr.encoding))\n (function Dal_parameters p -> Some ((), p) | _ -> None)\n (fun ((), p) -> Dal_parameters p)\n in\n union [case_raw_data; case_metadata; case_dal_page; case_dal_parameters]\n\nlet input_encoding =\n let open Data_encoding in\n let kind name = req \"input_kind\" (constant name) in\n let case_inbox_message =\n case\n ~title:\"inbox msg\"\n (Tag 0)\n (obj2 (kind \"inbox_message\") (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 (kind \"reveal_revelation\") (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 | Dal_parameters a, Dal_parameters b ->\n Sc_rollup_dal_parameters_repr.equal a b\n | Dal_parameters _, _ -> 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\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/6562\n Consider supporting revealing historical DAL parameters. *)\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 | Reveal_dal_parameters\n (** Request DAL parameters that were used for the slots published at\n the current inbox level. *)\n\nlet reveal_encoding =\n let open Data_encoding in\n let kind name = req \"reveal_kind\" (constant name) in\n let case_raw_data =\n case\n ~title:\"Reveal_raw_data\"\n (Tag 0)\n (obj2\n (kind \"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 (kind \"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 (kind \"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 let case_dal_parameters =\n case\n ~title:\"Reveal_dal_parameters\"\n (Tag 3)\n (obj1 (kind \"reveal_dal_parameters\"))\n (function Reveal_dal_parameters -> Some () | _ -> None)\n (fun () -> Reveal_dal_parameters)\n in\n union [case_raw_data; case_metadata; case_dal_page; case_dal_parameters]\n\n(** [is_reveal_enabled] is the type of a predicate that tells if a kind of\n reveal is activated at a certain block level. *)\ntype is_reveal_enabled = current_block_level:Raw_level_repr.t -> reveal -> bool\n\nlet is_reveal_enabled_predicate\n (t : Constants_parametric_repr.sc_rollup_reveal_activation_level) :\n is_reveal_enabled =\n fun ~current_block_level reveal ->\n let activation_level =\n match reveal with\n | Reveal_raw_data h -> (\n match Sc_rollup_reveal_hash.scheme_of_hash h with\n | Blake2B -> t.raw_data.blake2B)\n | Reveal_metadata -> t.metadata\n | Request_dal_page _ -> t.dal_page\n | Reveal_dal_parameters -> t.dal_parameters\n in\n Raw_level_repr.(current_block_level >= activation_level)\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 let kind name = req \"input_request_kind\" (constant name) in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"No_input_required\"\n (Tag 0)\n (obj1 (kind \"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 (kind \"initial\"))\n (function Initial -> Some () | _ -> None)\n (fun () -> Initial);\n case\n ~title:\"First_after\"\n (Tag 2)\n (obj3\n (kind \"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 (kind \"needs_reveal\") (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 | Reveal_dal_parameters -> Format.pp_print_string fmt \"Reveal DAL parameters\"\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_raw_data _, _ -> false\n | Reveal_metadata, Reveal_metadata -> true\n | Reveal_metadata, _ -> false\n | Request_dal_page a, Request_dal_page b -> Dal_slot_repr.Page.equal a b\n | Request_dal_page _, _ -> false\n | Reveal_dal_parameters, Reveal_dal_parameters -> true\n | Reveal_dal_parameters, _ -> 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 ~is_reveal_enabled 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 :\n is_reveal_enabled:is_reveal_enabled -> 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 ~is_reveal_enabled input p] checks the proof [p] with input [input]\n and returns the [input_request] before the evaluation of the proof. See the\n doc-string 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 :\n is_reveal_enabled:is_reveal_enabled ->\n input option ->\n proof ->\n input_request tzresult Lwt.t\n\n (** [produce_proof ctxt ~is_reveal_enabled input_given state] should return a [proof]\n for 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 :\n context ->\n is_reveal_enabled:is_reveal_enabled ->\n input option ->\n state ->\n 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 the [output_proof]'s output\n iff the proof is a valid witness that its [output] is part of its\n [state]'s outbox. *)\n val verify_output_proof : output_proof -> output tzresult 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\nmodule type Generic_pvm_context_sig = sig\n module Tree : 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\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\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:<num_slots>:<e>:<num_p>:<s1>:<s2>:...:<sn>] is interpreted as a directive\n to provide the DAL parameters to the PVM, where:\n - <num_slots> is the number of slots\n - <e> is the attestation lag;\n - <num_p> is the number of pages;\n - each <si> is a slot to which the PVM subscribes to for [current level -\n attestation_lag - 1].\n\n DAL parameters can be set at most once. At each Start_of_level of some level\n [L] inbox message and if DAL is enabled for the rollup (via the directive\n above), the PVM will request the pages of the slots it is subscribed to. The\n (attested) slots that are actually fetched at level [L] are those published\n at level [L - e - 1]. Note that providing some DAC data via a DAL page will\n prevent from fetching the subsequent DAL pages.\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 of Sc_rollup_PVM_sig.reveal\n | Parsing\n | Evaluating\n\n (** [get_status ~is_reveal_enabled state] returns the machine status in [state]. *)\n val get_status :\n is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n state ->\n 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\nmodule Make (Context : Sc_rollup_PVM_sig.Generic_pvm_context_sig) :\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\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 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 of Sc_rollup_PVM_sig.reveal\n | Parsing\n | Evaluating\n\n val get_status :\n is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n state ->\n 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 : Sc_rollup_PVM_sig.Generic_pvm_context_sig) :\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 of Sc_rollup_PVM_sig.reveal\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 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 let open Data_encoding in\n let kind name = req \"status\" (constant name) in\n let case_halted =\n case\n ~title:\"Halted\"\n (Tag 0)\n (obj1 (kind \"halted\"))\n (function Halted -> Some () | _ -> None)\n (fun () -> Halted)\n in\n let case_waiting_for_input_message =\n case\n ~title:\"Waiting_for_input_message\"\n (Tag 1)\n (obj1 (kind \"waiting_for_input_message\"))\n (function Waiting_for_input_message -> Some () | _ -> None)\n (fun () -> Waiting_for_input_message)\n in\n let case_waiting_for_reveal =\n case\n ~title:\"Waiting_for_reveal\"\n (Tag 2)\n (obj2\n (kind \"waiting_for_reveal\")\n (req \"reveal\" Sc_rollup_PVM_sig.reveal_encoding))\n (function Waiting_for_reveal r -> Some ((), r) | _ -> None)\n (fun ((), r) -> Waiting_for_reveal r)\n in\n let case_parsing =\n case\n ~title:\"Parsing\"\n (Tag 3)\n (obj1 (kind \"parsing\"))\n (function Parsing -> Some () | _ -> None)\n (fun () -> Parsing)\n in\n let case_evaluating =\n case\n ~title:\"Evaluating\"\n (Tag 4)\n (obj1 (kind \"evaluating\"))\n (function Evaluating -> Some () | _ -> None)\n (fun () -> Evaluating)\n in\n union\n [\n case_halted;\n case_waiting_for_input_message;\n case_waiting_for_reveal;\n case_parsing;\n case_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 reveal ->\n Format.asprintf\n \"Waiting for reveal %a\"\n Sc_rollup_PVM_sig.pp_reveal\n reveal\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 type dal_slots_list = Dal_slot_index_repr.t list\n\n let dal_slots_list_encoding =\n Data_encoding.list Dal_slot_index_repr.encoding\n\n let pp_dal_slots_list =\n Format.pp_print_list\n ~pp_sep:(fun fmt () -> Format.pp_print_string fmt \":\")\n Dal_slot_index_repr.pp\n\n type dal_parameters = {\n attestation_lag : int32;\n number_of_pages : int32;\n tracked_slots : dal_slots_list;\n }\n\n module Dal_parameters = Make_var (struct\n type t = dal_parameters\n\n let initial =\n (* This initial value is, from a semantic point of vue, equivalent to\n have [None], as no slot is tracked.\n\n For the initial values of the fields, only [tracked_slots]'s content\n matters. Setting it the empty set means that the rollup is not\n subscribed to the DAL. *)\n {attestation_lag = 1l; number_of_pages = 0l; tracked_slots = []}\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {attestation_lag; number_of_pages; tracked_slots} ->\n (attestation_lag, number_of_pages, tracked_slots))\n (fun (attestation_lag, number_of_pages, tracked_slots) ->\n {attestation_lag; number_of_pages; tracked_slots})\n (obj3\n (req \"attestation_lag\" int32)\n (req \"number_of_pages\" int32)\n (req \"tracked_slots\" dal_slots_list_encoding))\n\n let name = \"dal_parameters\"\n\n let pp fmt {attestation_lag; number_of_pages; tracked_slots} =\n Format.fprintf\n fmt\n \"dal:%ld:%ld:%a\"\n attestation_lag\n number_of_pages\n pp_dal_slots_list\n tracked_slots\n end)\n\n module Dal_remaining_slots = Make_var (struct\n type t = dal_slots_list\n\n let initial = []\n\n let encoding = dal_slots_list_encoding\n\n let name = \"dal_remaining_slots\"\n\n let pp = pp_dal_slots_list\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_reveal Reveal_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 get_status ~is_reveal_enabled : status Monad.t =\n let open Monad.Syntax in\n let* status = Status.get in\n let* current_block_level = Current_level.get in\n (* We do not put the machine in a stuck condition if a kind of reveal\n happens to not be supported. This is a sensible thing to do, as if\n there is an off-by-one error in the WASM kernel one can do an\n incorrect reveal, which can put the PVM in a stuck state with no way\n to upgrade the kernel to fix the off-by-one. *)\n let try_return_reveal candidate : status =\n match (current_block_level, candidate) with\n | _, Waiting_for_reveal candidate ->\n let is_enabled = is_reveal_enabled ~current_block_level candidate in\n if is_enabled then Waiting_for_reveal candidate\n else\n Waiting_for_reveal\n (Reveal_raw_data Sc_rollup_reveal_hash.well_known_reveal_hash)\n | _, _ -> candidate\n in\n return\n @@\n match status with\n | Waiting_for_reveal _ -> try_return_reveal status\n | s -> s\n\n let is_input_state_monadic ~is_reveal_enabled =\n let open Monad.Syntax in\n let* status = get_status ~is_reveal_enabled 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 (Reveal_raw_data _) -> (\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_reveal Reveal_metadata ->\n return PS.(Needs_reveal Reveal_metadata)\n | Waiting_for_reveal (Request_dal_page page) ->\n return PS.(Needs_reveal (Request_dal_page page))\n | Waiting_for_reveal Reveal_dal_parameters ->\n return PS.(Needs_reveal Reveal_dal_parameters)\n | Halted | Parsing | Evaluating -> return PS.No_input_required\n\n let is_input_state ~is_reveal_enabled =\n result_of ~default:PS.No_input_required\n @@ is_input_state_monadic ~is_reveal_enabled\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 let get_status ~is_reveal_enabled : state -> status Lwt.t =\n result_of ~default:Waiting_for_input_message (get_status ~is_reveal_enabled)\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 (** Compute and set the next Dal page to request if any. Otherwise, request\n the next inbox message.\n\n The value of [target] allows to compute the next page to request: either\n the first one the PVM is subscribed to, or the one after the given\n (slot_index, page_index) page. *)\n let next_dal_page dal_params ~target =\n let open Monad.Syntax in\n let open Dal_slot_repr in\n let module Index = Dal_slot_index_repr in\n let* case =\n match (dal_params, target) with\n | {tracked_slots = []; _}, `First_page _published_level ->\n (* PVM subscribed to no slot. *)\n return `Inbox_message\n | {tracked_slots = index :: rest; _}, `First_page published_level ->\n (* Initiate the DAL data fetching process with the first page of the\n first slot. *)\n let* () = Dal_remaining_slots.set rest in\n return (`Dal (published_level, index, 0))\n | ( {number_of_pages; _},\n `Page_after {Page.slot_id = {published_level; index}; page_index} )\n -> (\n (* We already read some DAL pages for the published level. Try one of\n the following in this order:\n - Attempt to move to the next page of the current slot;\n - In case all pages have been read; attempt to move to the next slot;\n - In case all slots have been read; request the next inbox message. *)\n let page_index = page_index + 1 in\n if Compare.Int.(page_index < Int32.to_int number_of_pages) then\n return (`Dal (published_level, index, page_index))\n else\n let* remaining_slots = Dal_remaining_slots.get in\n match remaining_slots with\n | index :: rest ->\n let* () = Dal_remaining_slots.set rest in\n return (`Dal (published_level, index, 0))\n | [] -> return `Inbox_message)\n in\n match case with\n | `Dal (published_level, index, page_index) ->\n let page_id = {Page.slot_id = {published_level; index}; page_index} in\n let* () = Required_reveal.set @@ Some (Request_dal_page page_id) in\n Status.set (Waiting_for_reveal (Request_dal_page page_id))\n | `Inbox_message ->\n let* () = Required_reveal.set None in\n Status.set Waiting_for_input_message\n\n (** Request a Dal page or an input message depending on the value of the given\n [published_level] argument and on the content of the {Required_reveal.get}.\n *)\n let update_waiting_for_data_status =\n let open Dal_slot_repr in\n let module Index = Dal_slot_index_repr in\n fun ?published_level () ->\n let open Monad.Syntax in\n let* dal_params = Dal_parameters.get in\n if List.is_empty dal_params.tracked_slots then\n (* This rollup doesn't track any DAL slot. *)\n Status.set Waiting_for_input_message\n else\n let* required_reveal = Required_reveal.get in\n (* Depending on whether [?published_level] is set, and on the value stored\n in [required_reveal], the next data to request may either be a DAL page\n or an inbox message. *)\n match (published_level, required_reveal) with\n | None, None ->\n (* The default case is to request an inbox message. *)\n Status.set Waiting_for_input_message\n | Some published_level, None ->\n (* We are explictely asked to start fetching DAL pages. *)\n next_dal_page dal_params ~target:(`First_page published_level)\n | Some published_level, Some (Request_dal_page page_id) ->\n (* We are moving to the next level, and there are no explicit inbox\n messages in the previous level. *)\n let* remaining_slots = Dal_remaining_slots.get in\n assert (\n let slot_id = page_id.Page.slot_id in\n let page_index = page_id.Page.page_index in\n Compare.Int.(\n Int32.to_int\n @@ Raw_level_repr.diff published_level slot_id.published_level\n = 1\n && List.is_empty remaining_slots\n && page_index = Int32.to_int dal_params.number_of_pages - 1)) ;\n next_dal_page dal_params ~target:(`First_page published_level)\n | None, Some (Request_dal_page page_id) ->\n (* We are in the same level, fetch the next page. *)\n next_dal_page dal_params ~target:(`Page_after page_id)\n | _, Some Reveal_metadata | _, Some Reveal_dal_parameters ->\n (* Should not happen. *)\n assert false\n | _, Some (Reveal_raw_data _) ->\n (* Note that, providing a DAC input via a DAL page will interrupt\n the interpretation of the next DAL pages of the same level, as the\n content of [Required_reveal] is lost. We should use two\n distinct states if we don't want this to happen. *)\n let* () = Required_reveal.set None in\n Status.set Waiting_for_input_message\n\n let set_inbox_message_monadic {PS.inbox_level; message_counter; payload} =\n let open Monad.Syntax in\n let deserialized = Sc_rollup_inbox_message_repr.deserialize payload in\n let* payload =\n match deserialized 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 (Protocol_migration _)) ->\n let* () = incr_internal_message_counter in\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 match deserialized with\n | Ok (Internal Start_of_level) -> (\n let* dal_params = Dal_parameters.get in\n let inbox_level = Raw_level_repr.to_int32 inbox_level in\n (* the [published_level]'s pages to request is [inbox_level -\n attestation_lag - 1]. *)\n let lvl =\n Int32.sub (Int32.sub inbox_level dal_params.attestation_lag) 1l\n in\n match Raw_level_repr.of_int32 lvl with\n | Error _ ->\n (* Too early. We cannot request DAL data yet. *)\n return ()\n | Ok published_level -> (\n let* metadata = Metadata.get in\n match metadata with\n | None ->\n assert false\n (* Setting Metadata should be the first input provided to the\n PVM. *)\n | Some {origination_level; _} ->\n if Raw_level_repr.(origination_level >= published_level)\n then\n (* We can only fetch DAL data that are published after\n the rollup's origination level. *)\n Status.set Waiting_for_input_message\n else\n (* Start fetching DAL data for this [published_level]. *)\n update_waiting_for_data_status ~published_level ()))\n | _ -> Status.set Waiting_for_input_message)\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 (* We may either move to the next DAL page or to the next inbox\n message. *)\n update_waiting_for_data_status ()\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 | PS.Dal_parameters _ ->\n (* Should not happen as requesting DAL parameters is disabled\n in the arith PVM. *)\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/6563\n Support reveal DAL parameters in arith PVM in order to test\n the refutation game for revealing DAL parameters. *)\n assert false\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 (* Once the evaluation of the current input is done, we either request the\n next DAL page or the next inbox message. *)\n update_waiting_for_data_status ()\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_hex hash with\n | None -> stop_evaluating false\n | Some hash ->\n let reveal : Sc_rollup_PVM_sig.reveal = Reveal_raw_data hash in\n let* () = Required_reveal.set (Some reveal) in\n let* () = Status.set (Waiting_for_reveal reveal) in\n return ()\n\n let evaluate_dal_parameters dal_directive =\n let dal_params =\n (* Dal pages import directive is [dal:<num_slots>:<e>:<num_p>:<s1>:<s2>:...:<sn>]. See\n mli file.*)\n let open Option_syntax in\n match String.split_on_char ':' dal_directive with\n | number_of_slots :: attestation_lag :: number_of_pages :: tracked_slots\n ->\n let* number_of_slots = Int32.of_string_opt number_of_slots in\n let* attestation_lag = Int32.of_string_opt attestation_lag in\n let* number_of_pages = Int32.of_string_opt number_of_pages in\n let* tracked_slots =\n let rec aux acc sl =\n match sl with\n | [] -> return (List.rev acc)\n | s :: rest ->\n let* dal_slot_int = int_of_string_opt s in\n let* dal_slot =\n Dal_slot_index_repr.of_int_opt\n ~number_of_slots:(Int32.to_int number_of_slots)\n dal_slot_int\n in\n (aux [@tailcall]) (dal_slot :: acc) rest\n in\n aux [] tracked_slots\n in\n Some {attestation_lag; number_of_pages; tracked_slots}\n | _ -> None\n in\n let open Monad.Syntax in\n match dal_params with\n | None -> stop_evaluating false\n | Some dal_params ->\n let* () = Dal_parameters.set dal_params in\n Status.set Waiting_for_input_message\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 reveal 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 dal_directive -> evaluate_dal_parameters dal_directive\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 _ -> (\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 ~is_reveal_enabled input_given state =\n let open Lwt_syntax in\n let* request = is_input_state ~is_reveal_enabled state in\n let error msg = state_of (internal_error msg) state in\n\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.Needs_reveal Reveal_dal_parameters, _ ->\n error\n \"Invalid set_input: revealing DAL parameters is not supported in \\\n the arith PVM.\"\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 ~is_reveal_enabled input_given proof =\n let open Lwt_result_syntax in\n let*! result =\n Context.verify_proof\n proof\n (step_transition ~is_reveal_enabled input_given)\n in\n match result with\n | None -> tzfail Arith_proof_verification_failed\n | Some (_state, request) -> return request\n\n let produce_proof context ~is_reveal_enabled input_given state =\n let open Lwt_result_syntax in\n let*! result =\n Context.produce_proof\n context\n state\n (step_transition ~is_reveal_enabled 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 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 message_index = Z.to_string message_index\n\n let get_output ~outbox_level ~message_index ~message state =\n let open Lwt_syntax in\n let* _state, output = run (Output.get (output_key message_index)) state in\n let output =\n let output = Option.join output in\n Option.bind\n output\n (fun\n {\n outbox_level = found_outbox_level;\n message = found_message;\n message_index = _;\n }\n ->\n (* We can safely ignore the [message_index] since it is the key\n used to fetch the messag from the storage. *)\n let found_message_encoded =\n Data_encoding.Binary.to_string_exn\n Sc_rollup_outbox_message_repr.encoding\n found_message\n in\n let given_message_encoded =\n Data_encoding.Binary.to_string_exn\n Sc_rollup_outbox_message_repr.encoding\n message\n in\n if\n Raw_level_repr.equal outbox_level found_outbox_level\n && Compare.String.equal found_message_encoded given_message_encoded\n then Some message\n else None)\n in\n return (state, output)\n\n let verify_output_proof p =\n let open Lwt_result_syntax in\n let outbox_level = p.output_proof_output.outbox_level in\n let message_index = p.output_proof_output.message_index in\n let message = p.output_proof_output.message in\n let transition = get_output ~outbox_level ~message_index ~message in\n let*! result = Context.verify_proof p.output_proof transition in\n match result with\n | Some (_state, Some message) ->\n return Sc_rollup_PVM_sig.{outbox_level; message_index; message}\n | _ -> tzfail Arith_output_proof_production_failed\n\n let produce_output_proof context state output_proof_output =\n let open Lwt_result_syntax in\n let outbox_level = output_proof_output.Sc_rollup_PVM_sig.outbox_level in\n let message_index = output_proof_output.message_index in\n let message = output_proof_output.message in\n let*! result =\n Context.produce_proof context state\n @@ get_output ~outbox_level ~message_index ~message\n in\n match result with\n | Some (output_proof, Some message) ->\n let*! output_proof_state = state_hash state in\n return\n {\n output_proof;\n output_proof_state;\n output_proof_output = {outbox_level; message_index; message};\n }\n | _ -> fail Arith_output_proof_production_failed\n\n module Internal_for_tests = struct\n let insert_failure state =\n let open Lwt_syntax in\n let add n = Tree.add state [\"failures\"; string_of_int n] Bytes.empty 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 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 val current_version : Wasm_2_0_0.version\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 ~is_reveal_enabled state] gives you the current execution status for the PVM. *)\n val get_status :\n is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n state ->\n 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 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\n (Lib_scoru_Wasm : Make_wasm)\n (Context : Sc_rollup_PVM_sig.Generic_pvm_context_sig) :\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 (** 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\n weeks. For a block time of 5 seconds, this equals to (60 * 60 *\n 24 * 14) / 5 = 241_920 blocks. We choose to consider 5 seconds\n instead of 10 proposed in protocol P to remove the need to\n introduce a new PVM version every time the block time is\n modified. We believe 5 seconds is small enough to be \"safe\" for\n multiple months. It does not create a critical issue, we will just keep\n more outboxes than expected. *)\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\n\n (** Convert a raw reveal request of the WASM PVM into a typed reveal as\n defined by the protocol.\n\n If the decoding fails, fallback to requesting the preimage of the\n {!well_known_reveal_hash}. *)\n val decode_reveal : Wasm_2_0_0.reveal -> Sc_rollup_PVM_sig.reveal\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_output_proof_verification_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 = \"Output proof verification failed\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wasm_output_proof_verification_failed\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function WASM_output_proof_verification_failed -> Some () | _ -> None)\n (fun () -> WASM_output_proof_verification_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 = \"Proof verification failed\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wasm_proof_verification_failed\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function WASM_proof_verification_failed -> Some () | _ -> None)\n (fun () -> WASM_proof_verification_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 current_version = Wasm_2_0_0.v4\n\n let ticks_per_snapshot = Z.of_int64 50_000_000_000_000L\n\n let outbox_validity_period = 241_920l\n\n let outbox_message_limit = Z.of_int 100\n\n let well_known_reveal_preimage =\n Sc_rollup_reveal_hash.well_known_reveal_preimage\n\n let well_known_reveal_hash = Sc_rollup_reveal_hash.well_known_reveal_hash\n\n let decode_reveal (Wasm_2_0_0.Reveal_raw payload) =\n match\n Data_encoding.Binary.of_string_opt\n Sc_rollup_PVM_sig.reveal_encoding\n payload\n with\n | Some reveal -> reveal\n | None ->\n (* If the kernel has tried to submit an incorrect reveal request,\n we don\226\128\153t stuck the rollup. Instead, we fallback to the\n requesting the [well_known_reveal_hash] preimage *)\n Reveal_raw_data well_known_reveal_hash\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 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 ~is_reveal_enabled state] gives you the current execution status for the PVM. *)\n val get_status :\n is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n state ->\n 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\n (Make_backend : Make_wasm)\n (Context : Sc_rollup_PVM_sig.Generic_pvm_context_sig) :\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 current_version 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_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 get_status ~is_reveal_enabled =\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 let* last_read = get_last_message_read in\n (* We do not put the machine in a stuck condition if a kind of reveal\n happens to not be supported. This is a sensible thing to do, as if\n there is an off-by-one error in the WASM kernel one can do an\n incorrect reveal, which can put the PVM in a stuck state with no way\n to upgrade the kernel to fix the off-by-one. *)\n let try_return_reveal candidate =\n match last_read with\n | Some (current_block_level, _) ->\n let is_enabled = is_reveal_enabled ~current_block_level candidate in\n if is_enabled then Waiting_for_reveal candidate\n else Waiting_for_reveal (Reveal_raw_data well_known_reveal_hash)\n | None -> Waiting_for_reveal (Reveal_raw_data well_known_reveal_hash)\n 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 req -> try_return_reveal (decode_reveal req)\n\n let is_input_state ~is_reveal_enabled =\n let open Monad.Syntax in\n let* status = get_status ~is_reveal_enabled 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 ~is_reveal_enabled =\n result_of (is_input_state ~is_reveal_enabled)\n\n let get_status ~is_reveal_enabled : state -> status Lwt.t =\n result_of (get_status ~is_reveal_enabled)\n\n let get_outbox outbox_level state =\n let open Lwt_syntax in\n let outbox_level_int32 =\n Raw_level_repr.to_int32_non_negative outbox_level\n 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_bytes) ->\n let content_bytes =\n Option.value ~default:Bytes.empty content_bytes\n (* [content_opt] is [None] when the slot was not confirmed in the L1.\n In this case, we return empty bytes.\n\n Note that the kernel can identify this unconfirmed slot scenario because\n all confirmed pages have a size of 4KiB. Thus, a page can only be considered\n empty (0KiB) if it is unconfirmed. *)\n in\n let* s = get in\n let* s = lift (WASM_machine.reveal_step content_bytes s) in\n set s\n | PS.Reveal (PS.Dal_parameters dal_parameters) ->\n (* FIXME: https://gitlab.com/tezos/tezos/-/issues/6544\n reveal_dal_parameters result for slow execution PVM. *)\n let dal_parameters_bytes =\n Data_encoding.Binary.to_bytes_exn\n Sc_rollup_dal_parameters_repr.encoding\n dal_parameters\n in\n let* s = get in\n let* s = lift (WASM_machine.reveal_step dal_parameters_bytes s) in\n set s\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 ~is_reveal_enabled input_given state =\n let open Lwt_syntax in\n let* request = is_input_state ~is_reveal_enabled 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 ~is_reveal_enabled input_given proof =\n let open Lwt_result_syntax in\n let*! result =\n Context.verify_proof\n proof\n (step_transition ~is_reveal_enabled input_given)\n in\n match result with\n | None -> tzfail WASM_proof_verification_failed\n | Some (_state, request) -> return request\n\n let produce_proof context ~is_reveal_enabled input_given state =\n let open Lwt_result_syntax in\n let*! result =\n Context.produce_proof\n context\n state\n (step_transition ~is_reveal_enabled 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 type output_proof = {\n output_proof : Context.proof;\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_output} ->\n (output_proof, output_proof_output))\n (fun (output_proof, output_proof_output) ->\n {output_proof; output_proof_output})\n (obj2\n (req \"output_proof\" Context.proof_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 = proof_start_state s.output_proof\n\n let get_output : PS.output -> Sc_rollup_outbox_message_repr.t option Monad.t\n =\n fun {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 = 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 @@ Option.bind result (fun result ->\n if Compare.String.(result = message_encoded) then Some message\n else None)\n\n let verify_output_proof p =\n let open Lwt_result_syntax in\n let transition = run @@ get_output p.output_proof_output in\n let*! result = Context.verify_proof p.output_proof transition in\n match result with\n | Some (_state, Some message) ->\n return\n Sc_rollup_PVM_sig.\n {\n outbox_level = p.output_proof_output.outbox_level;\n message_index = p.output_proof_output.message_index;\n message;\n }\n | _ -> tzfail WASM_output_proof_verification_failed\n\n let produce_output_proof context state output_proof_output =\n let open Lwt_result_syntax in\n let*! result =\n Context.produce_proof context state\n @@ run\n @@ get_output output_proof_output\n in\n match result with\n | Some (output_proof, Some message) ->\n return\n {\n output_proof;\n output_proof_output =\n {\n outbox_level = output_proof_output.outbox_level;\n message_index = output_proof_output.message_index;\n message;\n };\n }\n | _ -> 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 open Lwt_syntax in\n let add n = Tree.add state [\"failures\"; string_of_int n] Bytes.empty 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_rollup_riscv" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype void = |\n\ntype minimal_state = {\n payload : string;\n level : Raw_level_repr.t option;\n message_counter : Z.t;\n tick : Z.t;\n}\n\n(* This encoding is used in the rollup node when embedding the state into an Irmin context. *)\nval minimal_state_encoding : minimal_state Data_encoding.t\n\nval make_empty_state : unit -> minimal_state\n\nmodule 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\nend\n\nmodule Protocol_implementation :\n S\n with type context = unit\n and type state = minimal_state\n and type proof = void\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\nmodule PS = Sc_rollup_PVM_sig\n\n(* [void] definition from [Sc_rollup_machine_no_proofs] *)\ntype void = |\n\nlet void =\n Data_encoding.(\n conv_with_guard\n (function (_ : void) -> .)\n (fun _ -> Error \"void has no inhabitant\")\n unit)\n\ntype minimal_state = {\n payload : string;\n level : Raw_level_repr.t option;\n message_counter : Z.t;\n tick : Z.t;\n}\n\nlet minimal_state_encoding =\n let open Data_encoding in\n conv\n (fun {payload; level; message_counter; tick} ->\n (payload, level, message_counter, tick))\n (fun (payload, level, message_counter, tick) ->\n {payload; level; message_counter; tick})\n @@ obj4\n (req \"payload\" (string Hex))\n (req \"level\" (option Raw_level_repr.encoding))\n (req \"message_counter\" n)\n (req \"tick\" n)\n\nlet make_empty_state () =\n {payload = \"\"; level = None; message_counter = Z.zero; tick = Z.zero}\n\nlet state_hash state =\n [Data_encoding.Binary.to_bytes_exn minimal_state_encoding state]\n |> Context_hash.hash_bytes |> State_hash.context_hash_to_state_hash\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\nend\n\nmodule Protocol_implementation :\n S\n with type context = unit\n and type state = minimal_state\n and type proof = void = struct\n let pp state =\n Lwt.return @@ fun fmt () -> Format.pp_print_string fmt state.payload\n\n type state = minimal_state\n\n type context = unit\n\n type hash = State_hash.t\n\n type proof = void\n\n let proof_encoding = void\n\n let proof_start_state = function (_ : proof) -> .\n\n let proof_stop_state = function (_ : proof) -> .\n\n let state_hash state = Lwt.return (state_hash state)\n\n let initial_state ~empty = Lwt.return empty\n\n let install_boot_sector state boot_sector =\n Lwt.return {state with payload = boot_sector}\n\n let is_input_state ~is_reveal_enabled:_ state =\n Lwt.return\n @@\n match state.level with\n | None -> PS.Initial\n | Some level -> PS.First_after (level, state.message_counter)\n\n let set_input input state =\n Lwt.return\n @@\n match input with\n | PS.Inbox_message {inbox_level; message_counter; payload} ->\n {\n payload = Sc_rollup_inbox_message_repr.unsafe_to_string payload;\n level = Some inbox_level;\n message_counter;\n tick = Z.succ state.tick;\n }\n | PS.Reveal _s -> assert false\n\n let eval state = Lwt.return {state with tick = Z.succ state.tick}\n\n let verify_proof ~is_reveal_enabled:_ _input = function (_ : proof) -> .\n\n let produce_proof _context ~is_reveal_enabled:_ _state _step = assert false\n\n type output_proof = void\n\n let output_proof_encoding = void\n\n let output_of_output_proof = function (_ : proof) -> .\n\n let state_of_output_proof = function (_ : proof) -> .\n\n let verify_output_proof = function (_ : proof) -> .\n\n let produce_output_proof _context _state _output = assert false\n\n let check_dissection ~default_number_of_sections:_ ~start_chunk:_\n ~stop_chunk:_ =\n assert false\n\n let get_current_level {level; _} = Lwt.return level\n\n let parse_boot_sector s = Some s\n\n let pp_boot_sector fmt s = Format.fprintf fmt \"%s\" s\n\n module Internal_for_tests = struct\n let insert_failure _state = assert false\n end\nend\n" ;
} ;
{ name = "Sc_rollup_machine_no_proofs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 instantiation of both the WASM and Arith PVM which can\n be used to perform rollup computations, {b but} cannot be used to compute\n proofs. *)\n\ntype void = |\n\ntype t = Context_binary.t\n\ntype tree = Context_binary.tree\n\nval empty_tree : unit -> tree\n\nmodule type S = sig\n val parse_boot_sector : string -> string option\n\n val pp_boot_sector : Format.formatter -> string -> unit\n\n include\n Sc_rollup_PVM_sig.S\n with type context = t\n and type state = tree\n and type proof = void\nend\n\nmodule Arith : S\n\nmodule Wasm : S\n\nmodule Riscv : S\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 void = |\n\nlet void =\n Data_encoding.(\n conv_with_guard\n (function (_ : void) -> .)\n (fun _ -> Error \"void has no inhabitant\")\n unit)\n\ntype t = Context_binary.t\n\ntype tree = Context_binary.tree\n\nlet empty_tree () = Context_binary.(make_empty_context () |> Tree.empty)\n\nmodule Context_no_proofs = struct\n module Tree = Context_binary.Tree\n\n type tree = Context_binary.tree\n\n type proof = void\n\n let verify_proof = function (_ : proof) -> .\n\n let produce_proof _context _state _step = assert false\n\n let proof_before = function (_ : proof) -> .\n\n let proof_after = function (_ : proof) -> .\n\n let proof_encoding = void\nend\n\nmodule type S = sig\n val parse_boot_sector : string -> string option\n\n val pp_boot_sector : Format.formatter -> string -> unit\n\n include\n Sc_rollup_PVM_sig.S\n with type context = Context_no_proofs.Tree.t\n and type state = Context_no_proofs.tree\n and type proof = void\nend\n\nmodule Arith : S = Sc_rollup_arith.Make (Context_no_proofs)\n\nmodule Wasm : S =\n Sc_rollup_wasm.V2_0_0.Make (Wasm_2_0_0.Make) (Context_no_proofs)\n\nmodule Riscv : S = struct\n let parse_boot_sector _ = None\n\n let pp_boot_sector _fmtr _bs = ()\n\n type state = tree\n\n let pp _state = Lwt.return (fun _ _ -> ())\n\n type context = t\n\n type hash = Smart_rollup.State_hash.t\n\n type proof = void\n\n let proof_encoding = void\n\n let elim_void = function (_ : void) -> .\n\n let proof_start_state = elim_void\n\n let proof_stop_state = elim_void\n\n let state_hash _state =\n Sc_rollup_riscv.(Protocol_implementation.state_hash (make_empty_state ()))\n\n let initial_state ~empty = Lwt.return empty\n\n let install_boot_sector state _bs = Lwt.return state\n\n let is_input_state ~is_reveal_enabled:_ _state =\n failwith \"is_input_state: unimplemented\"\n\n let set_input _input _state = failwith \"set_input: unimplemented\"\n\n let eval _state = failwith \"eval: unimplemented\"\n\n let verify_proof ~is_reveal_enabled:_ _input_opt = elim_void\n\n let produce_proof _ctxt ~is_reveal_enabled:_ _input_opt _state =\n failwith \"produce_proof: unimplemented\"\n\n type output_proof = void\n\n let output_proof_encoding = void\n\n let output_of_output_proof = elim_void\n\n let state_of_output_proof = elim_void\n\n let verify_output_proof = elim_void\n\n let produce_output_proof _ctxt _state _out =\n failwith \"produce_output_proof: unimplemented\"\n\n let check_dissection ~default_number_of_sections:_ ~start_chunk:_\n ~stop_chunk:_ _chunks =\n failwith \"check_dissection: unimplemented\"\n\n let get_current_level _state = failwith \"get_current_level: unimplemented\"\n\n module Internal_for_tests = struct\n let insert_failure _state = failwith \"insert_failure: unimplemented\"\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 | Riscv\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 PVMs. *)\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\n(** [genesis_hash_of machine ~boot_sector] computes the initial state hash of a\n rollup given an initial [boot_sector]. *)\nval genesis_state_hash_of :\n boot_sector:string -> Kind.t -> Sc_rollup_repr.State_hash.t Lwt.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(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 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_string] and [encoding] ;\n - to update [Sc_rollups.wrapped_proof] and [wrapped_proof_encoding].\n\n *)\n type t = Example_arith | Wasm_2_0_0 | Riscv\n\n let all = [Example_arith; Wasm_2_0_0; Riscv]\n\n let to_string = function\n | Example_arith -> \"arith\"\n | Wasm_2_0_0 -> \"wasm_2_0_0\"\n | Riscv -> \"riscv\"\n\n let of_string = function\n | \"arith\" -> Some Example_arith\n | \"wasm_2_0_0\" -> Some Wasm_2_0_0\n | \"riscv\" -> Some Riscv\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 | Riscv -> Format.pp_print_string fmt \"riscv\"\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 | Riscv, Riscv -> 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 riscv_pvm = PVM.Packed (module Sc_rollup_riscv.Protocol_implementation)\n\n let pvm_of = function\n | Example_arith -> example_arith_pvm\n | Wasm_2_0_0 -> wasm_2_0_0_pvm\n | Riscv -> riscv_pvm\n\n let no_proof_machine_of : t -> (module Sc_rollup_machine_no_proofs.S) =\n function\n | Example_arith -> (module Sc_rollup_machine_no_proofs.Arith)\n | Wasm_2_0_0 -> (module Sc_rollup_machine_no_proofs.Wasm)\n | Riscv -> (module Sc_rollup_machine_no_proofs.Riscv)\nend\n\nlet genesis_state_hash_of ~boot_sector kind =\n let open Lwt_syntax in\n let (module Machine) = Kind.no_proof_machine_of kind in\n let empty = Sc_rollup_machine_no_proofs.empty_tree () in\n let* tree = Machine.initial_state ~empty in\n let* tree = Machine.install_boot_sector tree boot_sector in\n Machine.state_hash tree\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 {!S.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_repr} 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 with type t = Smart_rollup.Inbox_hash.t\n\nmodule Skip_list : Skip_list.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 witness and further\n back-pointers.\n\n In terms of size, this type is a small set of hashes; one for the\n current witness and `O(log2(ix))` in the back-pointers, where [ix]\n 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 witness). *)\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\n The expected value of [protocol_migration_message] is either [Some\n Raw_context.protocol_migration_internal_message] (during the first\n block of this protocol) or [None]. *)\nval add_all_messages :\n protocol_migration_message:\n Sc_rollup_inbox_message_repr.internal_inbox_message option ->\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(** 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\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\n\n(** [genesis ~protocol_migration_message ~timestamp ~predecessor\n level] initializes the inbox at some given [level] with: [SOL],\n [protocol_migration_message], [Info_per_level {timestamp;\n predecessor}] and [EOL] inside.\n\n The expected value of [protocol_migration_message] is\n [Raw_context.protocol_migration_internal_message]. *)\nval genesis :\n protocol_migration_message:Sc_rollup_inbox_message_repr.serialized ->\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n Raw_level_repr.t ->\n t\n\nmodule Internal_for_tests : sig\n (** Given a inbox [A] at some level [L] and another inbox [B] at some level\n [L' >= L], an [inclusion_proof] guarantees that [A] is an older version of\n [B].\n\n To be more precise, an [inclusion_proof] guarantees that the previous\n levels [witness]s of [A] are included in the previous levels [witness]s of\n [B]. The current [witness] of [A] and [B] are not considered.\n\n The size of this proof is O(log2 (L' - L)). *)\n type inclusion_proof = history_proof list\n\n val pp_inclusion_proof : Format.formatter -> inclusion_proof -> unit\n\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 (** [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. *)\n val verify_inclusion_proof :\n inclusion_proof -> history_proof -> history_proof tzresult\n\n type payloads_proof = {\n proof : Sc_rollup_inbox_merkelized_payload_hashes_repr.proof;\n payload : Sc_rollup_inbox_message_repr.serialized option;\n }\n\n val pp_payloads_proof : Format.formatter -> payloads_proof -> unit\n\n val produce_payloads_proof :\n (Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.t Lwt.t) ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t ->\n index:Z.t ->\n payloads_proof tzresult Lwt.t\n\n val verify_payloads_proof :\n payloads_proof ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t ->\n Z.t ->\n Sc_rollup_inbox_message_repr.serialized option tzresult\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\n\n type level_proof = {\n hash : Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t;\n level : Raw_level_repr.t;\n }\n\n val level_proof_of_history_proof : history_proof -> level_proof\n\n val expose_proof : proof -> inclusion_proof * payloads_proof\n\n val make_proof : inclusion_proof -> payloads_proof -> proof\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)\nmodule Hash = Smart_rollup.Inbox_hash\n\nmodule Skip_list_parameters = struct\n let basis = 4\nend\n\nmodule Skip_list = Skip_list.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 payloads_proof = {\n proof : Sc_rollup_inbox_merkelized_payload_hashes_repr.proof;\n payload : Sc_rollup_inbox_message_repr.serialized option;\n}\n\nlet payloads_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_protocol_internal_message_no_history payload witness =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.add_payload_no_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\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\n(** [archive_no_history inbox witness] archives the current inbox level. Updates\n the [inbox.current_level] and [inbox.old_levels_messages]. *)\nlet archive_no_history inbox witness =\n let old_levels_messages =\n let prev_cell = inbox.old_levels_messages in\n let prev_cell_ptr = hash_history_proof prev_cell 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 Skip_list.next ~prev_cell ~prev_cell_ptr current_level_proof\n in\n {inbox with old_levels_messages}\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 = Format.pp_print_list pp_history_proof\n\nlet pp_payloads_proof fmt {proof; payload} =\n Format.fprintf\n fmt\n \"payload: %a@,@[<v 2>proof:@,%a@]\"\n Format.(\n pp_print_option\n ~none:(fun fmt () -> pp_print_string fmt \"None\")\n (fun fmt payload ->\n pp_print_string\n fmt\n (Sc_rollup_inbox_message_repr.unsafe_to_string payload)))\n payload\n Sc_rollup_inbox_merkelized_payload_hashes_repr.pp_proof\n 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 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 = {inclusion_proof : inclusion_proof; message_proof : payloads_proof}\n\nlet pp_proof fmt {inclusion_proof; message_proof} =\n Format.fprintf\n fmt\n \"@[<v>@[<v 2>inclusion proof:@,%a@]@,@[<v 2>payloads proof:@,%a@]@]\"\n pp_inclusion_proof\n inclusion_proof\n pp_payloads_proof\n message_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\" payloads_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_payloads_history head_cell_hash ~index]\n\n [get_payloads_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_payloads_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_payloads_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 Result_syntax.tzfail\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 <= head_cell_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 | [] -> tzfail (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 return (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 let open Result_syntax in\n assert (Z.(geq n zero)) ;\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 sol = Sc_rollup_inbox_message_repr.start_of_level_serialized in\n Sc_rollup_inbox_merkelized_payload_hashes_repr.genesis_no_history sol\n\nlet add_info_per_level ~predecessor_timestamp ~predecessor payloads_history\n witness =\n let info_per_level =\n Sc_rollup_inbox_message_repr.info_per_level_serialized\n ~predecessor_timestamp\n ~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 info_per_level =\n Sc_rollup_inbox_message_repr.info_per_level_serialized\n ~predecessor_timestamp\n ~predecessor\n in\n add_protocol_internal_message_no_history info_per_level 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 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 witness = add_protocol_internal_message_no_history eol witness in\n archive_no_history inbox witness\n\nlet add_all_messages ~protocol_migration_message ~predecessor_timestamp\n ~predecessor history inbox messages =\n let open Result_syntax in\n let* payloads = List.map_e Sc_rollup_inbox_message_repr.serialize messages in\n let is_first_block = Option.is_some protocol_migration_message 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 =\n (List.length payloads + 3 + if is_first_block then 1 else 0)\n |> Int64.of_int\n in\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.empty ~capacity\n in\n (* Add [SOL], [Info_per_level], and possibly [Protocol_migration]. *)\n let* payloads_history, witness = init_witness payloads_history in\n\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 protocol_migration_message with\n | Some protocol_migration_message ->\n let* message =\n Sc_rollup_inbox_message_repr.serialize\n (Internal protocol_migration_message)\n in\n add_message message payloads_history witness\n | None -> return (payloads_history, 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 migration =\n Option.fold\n ~none:[]\n ~some:(fun x -> [Internal x])\n protocol_migration_message\n in\n let eol = Internal End_of_level in\n [sol] @ [info_per_level] @ migration @ messages @ [eol]\n in\n\n return (payloads_history, history, inbox, witness, messages)\n\nlet genesis ~protocol_migration_message ~predecessor_timestamp ~predecessor\n level =\n (* 1. Add [SOL], [Info_per_level] and [Protocol_migration]. *)\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 let witness =\n add_protocol_internal_message_no_history protocol_migration_message witness\n in\n\n (* 2. Add [EOL]. *)\n let eol = Sc_rollup_inbox_message_repr.end_of_level_serialized in\n let witness = add_protocol_internal_message_no_history eol witness 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 {level; old_levels_messages = Skip_list.genesis level_proof}\n\nmodule Internal_for_tests = struct\n type nonrec inclusion_proof = inclusion_proof\n\n let pp_inclusion_proof = pp_inclusion_proof\n\n let produce_inclusion_proof = produce_inclusion_proof\n\n let verify_inclusion_proof = verify_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\n\n type nonrec payloads_proof = payloads_proof = {\n proof : Sc_rollup_inbox_merkelized_payload_hashes_repr.proof;\n payload : Sc_rollup_inbox_message_repr.serialized option;\n }\n\n let pp_payloads_proof = pp_payloads_proof\n\n let produce_payloads_proof = produce_payloads_proof\n\n let verify_payloads_proof = verify_payloads_proof\n\n type nonrec level_proof = 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_of_history_proof = Skip_list.content\n\n let expose_proof {inclusion_proof; message_proof} =\n (inclusion_proof, message_proof)\n\n let make_proof inclusion_proof message_proof =\n {inclusion_proof; message_proof}\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 with type t = Smart_rollup.Commitment_hash.t\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 (and including) [inbox_level]\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_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\nmodule Hash = struct\n include Smart_rollup.Commitment_hash\n include Path_encoding.Make_hex (Smart_rollup.Commitment_hash)\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 | Dal_parameters_proof\n (** Proof for revealing DAL parameters that were used for the slots\n published at [published_level]. The [published_level] parameter\n enables the kernel to retrieve historical DAL parameters,\n eliminating the need for each kernel to store past DAL parameters. *)\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 related parameters, to be able to check the page content membership\n to a slot or check the revealed parameters if needed ;\n\n - the [pvm_name], used to check that the proof given has the right\n PVM kind.\n\n - The level at which DAL is activated (None if the DAL is not enabled).\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_activation_level:Raw_level_repr.t option ->\n dal_attestation_lag:int ->\n dal_number_of_slots:int ->\n is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n dal_attested_slots_validity_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 attestation is published on L1\n (its published_level) and the level it should be confirmed. *)\n val dal_attestation_lag : int\n\n (** The number of DAL slots provided by the L1. *)\n val dal_number_of_slots : int\n\n (** The level at which the DAL got activated, [None] if the DAL has not yet been activated. *)\n val dal_activation_level : Raw_level_repr.t option\n\n val dal_attested_slots_validity_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 is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n serialized t tzresult Lwt.t\n\nmodule Dal_helpers : sig\n (** We consider that a DAL page or slot published at a level [published_level]\n is valid, and produce or verify a proof for it if, and only if, the level\n is in the following boundaries:\n\n - DAL is activated and [published_level] >= [dal_activation_level]\n - [published_level] > [origination_level]: this means that the slot of the\n page was published after the rollup origination ;\n\n - [published_level] + [dal_attestation_lag] <= [commit_inbox_level]: this\n means that the slot of the page has been attested before or at the\n [commit_inbox_level].\n\n According to the definition in {!Sc_rollup_commitment_repr},\n [commit_inbox_level] (aka inbox_level in that module) is the level\n (included) up to which the PVM consumed all messages and DAL/DAC inputs\n before producing the related commitment.\n We also check that the given slot ID's index is within the range of\n allowed slots thanks to [dal_number_of_slots]. *)\n val import_level_is_valid :\n dal_activation_level:Raw_level_repr.t option ->\n dal_attestation_lag:int ->\n origination_level:Raw_level_repr.t ->\n commit_inbox_level:Raw_level_repr.t ->\n published_level:Raw_level_repr.t ->\n dal_attested_slots_validity_lag:int ->\n bool\nend\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 | Dal_parameters_proof\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 let case_dal_parameters =\n case\n ~title:\"dal parameters proof\"\n (Tag 3)\n (obj1 (req \"reveal_proof_kind\" (constant \"dal_parameters_proof\")))\n (function Dal_parameters_proof -> Some () | _ -> None)\n (fun () -> Dal_parameters_proof)\n in\n union [case_raw_data; case_metadata_proof; case_dal_page; case_dal_parameters]\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 -> tzfail (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 -> tzfail (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_unit 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 -> Result_syntax.tzfail 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_helpers = 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\n let import_level_is_valid ~dal_activation_level ~dal_attestation_lag\n ~origination_level ~commit_inbox_level ~published_level\n ~dal_attested_slots_validity_lag =\n (* [dal_attestation_lag] is supposed to be positive. *)\n let open Raw_level_repr in\n let dal_was_activated =\n match dal_activation_level with\n | None -> false\n | Some dal_activation_level -> published_level >= dal_activation_level\n in\n let slot_published_after_origination =\n published_level > origination_level\n in\n let not_too_recent =\n add published_level dal_attestation_lag <= commit_inbox_level\n in\n (* An attested slot is not expired if its attested level (equal to\n [published_level + dal_attestation_lag]) is not further than\n [dal_attested_slots_validity_lag] from the given inbox level. *)\n let ttl_not_expired =\n Raw_level_repr.(\n add\n (add published_level dal_attestation_lag)\n dal_attested_slots_validity_lag\n >= commit_inbox_level)\n in\n dal_was_activated && slot_published_after_origination && not_too_recent\n && ttl_not_expired\n\n let page_id_is_valid ~dal_number_of_slots ~dal_activation_level\n ~dal_attestation_lag ~origination_level ~commit_inbox_level\n cryptobox_parameters\n Dal_slot_repr.Page.{slot_id = {published_level; index}; page_index}\n ~dal_attested_slots_validity_lag =\n let open Dal_slot_repr in\n Result.is_ok\n (Page.Index.check_is_in_range\n ~number_of_pages:(Page.pages_per_slot cryptobox_parameters)\n page_index)\n && Result.is_ok\n (Dal_slot_index_repr.check_is_in_range\n ~number_of_slots:dal_number_of_slots\n index)\n && import_level_is_valid\n ~dal_activation_level\n ~dal_attestation_lag\n ~origination_level\n ~commit_inbox_level\n ~published_level\n ~dal_attested_slots_validity_lag\n\n let verify ~metadata ~dal_activation_level ~dal_attestation_lag\n ~dal_number_of_slots ~commit_inbox_level dal_parameters page_id\n dal_snapshot proof ~dal_attested_slots_validity_lag =\n let open Result_syntax in\n if\n page_id_is_valid\n dal_parameters\n ~dal_activation_level\n ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level\n ~dal_attestation_lag\n ~commit_inbox_level\n ~dal_number_of_slots\n page_id\n ~dal_attested_slots_validity_lag\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_activation_level ~dal_attestation_lag\n ~dal_number_of_slots ~commit_inbox_level dal_parameters page_id ~page_info\n ~get_history confirmed_slots_history ~dal_attested_slots_validity_lag =\n let open Lwt_result_syntax in\n if\n page_id_is_valid\n dal_parameters\n ~dal_number_of_slots\n ~dal_activation_level\n ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level\n ~dal_attestation_lag\n ~commit_inbox_level\n page_id\n ~dal_attested_slots_validity_lag\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\n ~dal_activation_level ~dal_attestation_lag ~dal_number_of_slots\n ~is_reveal_enabled ~dal_attested_slots_validity_lag (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_helpers.verify\n ~dal_number_of_slots\n ~metadata\n ~dal_activation_level\n ~dal_attested_slots_validity_lag\n dal_parameters\n ~dal_attestation_lag\n ~commit_inbox_level\n page_id\n dal_snapshot\n proof\n |> Lwt.return\n | Some (Reveal_proof Dal_parameters_proof) ->\n (* FIXME: https://gitlab.com/tezos/tezos/-/issues/6562\n Support revealing historical DAL parameters.\n\n Currently, we do not support revealing DAL parameters for the past.\n We ignore the given [published_level] and use the DAL parameters. *)\n return_some\n (Sc_rollup_PVM_sig.Reveal\n (Dal_parameters\n Sc_rollup_dal_parameters_repr.\n {\n number_of_slots = Int64.of_int dal_number_of_slots;\n attestation_lag = Int64.of_int dal_attestation_lag;\n slot_size = Int64.of_int dal_parameters.slot_size;\n page_size = Int64.of_int dal_parameters.page_size;\n }))\n in\n let input =\n Option.bind input (cut_at_level ~origination_level ~commit_inbox_level)\n in\n let* input_requested =\n P.verify_proof ~is_reveal_enabled input proof.pvm_step\n 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 | ( Some (Reveal_proof Dal_parameters_proof),\n Needs_reveal Reveal_dal_parameters ) ->\n return_unit\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\n val dal_number_of_slots : int\n\n val dal_activation_level : Raw_level_repr.t option\n\n val dal_attested_slots_validity_lag : int\n end\nend\n\nlet produce ~metadata pvm_and_state commit_inbox_level ~is_reveal_enabled =\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 ~is_reveal_enabled 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_helpers.produce\n ~dal_number_of_slots\n ~metadata\n ~dal_activation_level\n dal_parameters\n ~dal_attestation_lag\n ~commit_inbox_level\n page_id\n ~page_info\n ~get_history\n ~dal_attested_slots_validity_lag\n confirmed_slots_history\n | Needs_reveal Reveal_dal_parameters ->\n let open Dal_with_history in\n return\n ( Some (Reveal_proof Dal_parameters_proof),\n Some\n Sc_rollup_PVM_sig.(\n Reveal\n (Dal_parameters\n Sc_rollup_dal_parameters_repr.\n {\n number_of_slots = Int64.of_int dal_number_of_slots;\n attestation_lag = Int64.of_int dal_attestation_lag;\n slot_size = Int64.of_int dal_parameters.slot_size;\n page_size = Int64.of_int dal_parameters.page_size;\n })) )\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 =\n P.produce_proof P.context ~is_reveal_enabled input_given P.state\n 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_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model skip_list/hash_cell *)\n(* fun size -> max 10 (250. + (57. * size)) *)\nlet cost_hash_cell size = (size * S.safe_int 57) + S.safe_int 250\n\n(* model skip_list/next *)\n(* fun size -> max 10 (19.2125537461 * (log2 (1 + size))) *)\nlet cost_next size =\n let w1 = log2 (size + S.safe_int 1) in\n S.max (S.safe_int 10) ((w1 * S.safe_int 19) + (w1 lsr 1))\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(* Copyright (c) 2023 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 Skip_list_costs_generated\n\nlet model_next ~length = cost_next (S.safe_z length)\n\nlet model_hash_cell ~backpointers_count =\n cost_hash_cell (S.safe_int backpointers_count)\n\nlet model_hash_cell_computed_backpointers_count ~index =\n cost_hash_cell (S.Syntax.log2 (S.safe_z index))\n" ;
} ;
{ name = "Sc_rollup_costs_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model sc_rollup/Sc_rollup_deserialize_output_proof_benchmark *)\n(* fun size -> max 10 (7100. + (6. * size)) *)\nlet cost_Sc_rollup_deserialize_output_proof_benchmark size =\n let size = S.safe_int size in\n (size * S.safe_int 6) + S.safe_int 7100\n\n(* model sc_rollup/Sc_rollup_install_boot_sector_benchmark *)\n(* fun size -> max 10 (13550. + (3.5 * size)) *)\nlet cost_Sc_rollup_install_boot_sector_benchmark size =\n let size = S.safe_int size in\n (size lsr 1) + (size * S.safe_int 3) + S.safe_int 13550\n\n(* model sc_rollup/Sc_rollup_verify_output_proof_benchmark *)\n(* fun size -> max 10 (103450. + (7. * size)) *)\nlet cost_Sc_rollup_verify_output_proof_benchmark size =\n let size = S.safe_int size in\n (size * S.safe_int 7) + S.safe_int 103450\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. *)\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\n(** [cost_install_boot_sector_in_wasm_pvm ~boot_sector_size_in_bytes]\n returns the cost of installing a boot sector in an empty WASM PVM\n state. This function is used in the implementation of the\n origination. *)\nval cost_install_boot_sector_in_wasm_pvm :\n boot_sector_size_in_bytes:int -> Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2023 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 Sc_rollup_costs_generated\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 open S.Syntax in\n let fixed_cost = S.safe_int 10 in\n let coeff = S.safe_int 6 in\n fixed_cost + (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 | Protocol_migration _ -> Saturation_repr.zero\n | Info_per_level _ -> Saturation_repr.zero\n\nlet cost_deserialize_output_proof ~bytes_len =\n cost_Sc_rollup_deserialize_output_proof_benchmark bytes_len\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 = Michelson_v1_gas_costs.cost_N_ICompare\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\nlet cost_verify_output_proof ~bytes_len =\n cost_Sc_rollup_verify_output_proof_benchmark bytes_len\n\nlet cost_install_boot_sector_in_wasm_pvm ~boot_sector_size_in_bytes =\n cost_Sc_rollup_install_boot_sector_benchmark boot_sector_size_in_bytes\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 {!type-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(* 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 related parameters are used in case the game needs to:\n - Check that a page's content is part of a slot (using the slot's commitment)\n when refuting a DAL page reveal.\n - Check that the parameters are correct when refuting a DAL parameter reveal.\n*)\nval play :\n Sc_rollups.Kind.t ->\n Dal_slot_repr.parameters ->\n dal_activation_level:Raw_level_repr.t option ->\n dal_attestation_lag:int ->\n dal_number_of_slots:int ->\n stakers:Index.t ->\n Sc_rollup_metadata_repr.t ->\n t ->\n step:step ->\n choice:Sc_rollup_tick_repr.t ->\n is_reveal_enabled:Sc_rollup_PVM_sig.is_reveal_enabled ->\n dal_attested_slots_validity_lag:int ->\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 -> Error (Format.sprintf \"Invalid game index notation %s\" s))\n | _ -> 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 Ok (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_activation_level\n ~dal_attestation_lag ~dal_number_of_slots ~first_move ~metadata ~proof ~game\n ~start_chunk ~stop_chunk ~is_reveal_enabled ~dal_attested_slots_validity_lag\n =\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_activation_level\n ~dal_attestation_lag\n ~dal_number_of_slots\n ~is_reveal_enabled\n ~dal_attested_slots_validity_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 Result_syntax.return_unit\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_activation_level\n ~dal_attestation_lag ~dal_number_of_slots ~metadata ~proof ~game\n ~start_chunk ~stop_chunk =\n validity_final_move\n ~pvm\n ~dal_parameters\n ~dal_activation_level\n ~dal_attestation_lag\n ~dal_number_of_slots\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_activation_level\n ~dal_attestation_lag ~dal_number_of_slots ~metadata ~agreed_start_chunk\n ~refuted_stop_chunk ~game ~proof =\n validity_final_move\n ~pvm\n ~dal_parameters\n ~dal_activation_level\n ~dal_attestation_lag\n ~dal_number_of_slots\n ~first_move:false\n ~metadata\n ~proof\n ~game\n ~start_chunk:agreed_start_chunk\n ~stop_chunk:refuted_stop_chunk\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 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 @@ Michelson_v1_gas_costs.cost_N_IBlake2b overapproximated_hashing_size\n\nlet play kind dal_parameters ~dal_activation_level ~dal_attestation_lag\n ~dal_number_of_slots ~stakers metadata game ~step ~choice ~is_reveal_enabled\n ~dal_attested_slots_validity_lag =\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_activation_level\n ~dal_attestation_lag\n ~dal_number_of_slots\n ~proof\n ~metadata\n ~game\n ~start_chunk\n ~stop_chunk\n ~is_reveal_enabled\n ~dal_attested_slots_validity_lag\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_activation_level\n ~dal_attestation_lag\n ~dal_number_of_slots\n ~metadata\n ~agreed_start_chunk\n ~refuted_stop_chunk\n ~game\n ~proof\n ~is_reveal_enabled\n ~dal_attested_slots_validity_lag\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_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 = "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 of {given : int; limit : int}\n | Dal_publish_commitment_invalid_index of {\n given : Dal_slot_index_repr.t;\n maximum : Dal_slot_index_repr.t;\n }\n | Dal_publish_commitment_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_commitment_duplicate of {slot_header : Dal_slot_repr.Header.t}\n | Dal_publish_commitment_invalid_proof of {\n commitment : Dal.commitment;\n commitment_proof : Dal.commitment_proof;\n }\n | Dal_data_availibility_attester_not_in_committee of {\n attester : Signature.Public_key_hash.t;\n level : Raw_level_repr.t;\n slot : Slot_repr.t;\n }\n | Dal_cryptobox_error of {explanation : string}\n | Dal_register_invalid_slot_header of {\n length : int;\n slot_header : Dal_slot_repr.Header.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 = \"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 (given, limit) ->\n Format.fprintf\n ppf\n \"%s (given %Ld): Maximum allowed %Ld.\"\n description\n given\n limit)\n (obj2 (req \"given\" Data_encoding.int64) (req \"limit\" Data_encoding.int64))\n (function\n | Dal_slot_index_above_hard_limit {given; limit} ->\n Some (Int64.of_int given, Int64.of_int limit)\n | _ -> None)\n (fun (given, limit) ->\n Dal_slot_index_above_hard_limit\n {given = Int64.to_int given; limit = Int64.to_int limit}) ;\n let description = \"Bad index for slot header\" in\n register_error_kind\n `Permanent\n ~id:\"dal_publish_commitment_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_index_repr.pp\n given\n Dal_slot_index_repr.pp\n maximum)\n (obj2\n (req \"given\" Dal_slot_index_repr.encoding)\n (req \"got\" Dal_slot_index_repr.encoding))\n (function\n | Dal_publish_commitment_invalid_index {given; maximum} ->\n Some (given, maximum)\n | _ -> None)\n (fun (given, maximum) ->\n Dal_publish_commitment_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_commitment_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_commitment_candidate_with_low_fees {proposed_fees} ->\n Some proposed_fees\n | _ -> None)\n (fun proposed_fees ->\n Dal_publish_commitment_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_commitment_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_commitment_duplicate {slot_header} -> Some slot_header\n | _ -> None)\n (fun slot_header -> Dal_publish_commitment_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_commitment_invalid_proof\"\n ~title:\"DAL publish slot header invalid proof\"\n ~description\n ~pp:(fun ppf _proposed -> Format.fprintf ppf \"%s\" description)\n (obj2\n (req \"commitment\" Dal.Commitment.encoding)\n (req \"commitment_proof\" Dal.Commitment_proof.encoding))\n (function\n | Dal_publish_commitment_invalid_proof {commitment; commitment_proof} ->\n Some (commitment, commitment_proof)\n | _ -> None)\n (fun (commitment, commitment_proof) ->\n Dal_publish_commitment_invalid_proof {commitment; commitment_proof}) ;\n register_error_kind\n `Permanent\n ~id:\"Dal_data_availibility_attester_not_in_committee\"\n ~title:\"The attester is not part of the DAL committee for this level\"\n ~description:\"The attester is not part of the DAL committee for this level\"\n ~pp:(fun ppf (attester, level, slot) ->\n Format.fprintf\n ppf\n \"The attester %a, with slot %a, is not part of the DAL committee for \\\n the level %a.\"\n Signature.Public_key_hash.pp\n attester\n Slot_repr.pp\n slot\n Raw_level_repr.pp\n level)\n Data_encoding.(\n obj3\n (req \"attester\" Signature.Public_key_hash.encoding)\n (req \"level\" Raw_level_repr.encoding)\n (req \"slot\" Slot_repr.encoding))\n (function\n | Dal_data_availibility_attester_not_in_committee {attester; level; slot}\n ->\n Some (attester, level, slot)\n | _ -> None)\n (fun (attester, level, slot) ->\n Dal_data_availibility_attester_not_in_committee {attester; level; slot}) ;\n register_error_kind\n `Permanent\n ~id:\"dal_cryptobox_error\"\n ~title:\"DAL cryptobox error\"\n ~description:\"Error occurred while initialising the cryptobox\"\n ~pp:(fun ppf e ->\n Format.fprintf ppf \"DAL cryptobox initialisation error: %s\" e)\n (obj1 (req \"error\" (string Plain)))\n (function\n | Dal_cryptobox_error {explanation} -> Some explanation | _ -> None)\n (fun explanation -> Dal_cryptobox_error {explanation}) ;\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 %d. \\\n Found: %a.\"\n length\n Dal_slot_index_repr.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" ;
} ;
{ name = "Dal_operations_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(** {1 DAL operations}\n\n This module gathers the datatypes for the payloads of DAL operations.\n\n This module ensures the consistency with the internal\n data-structures like [Dal_slot_index_repr.t]. *)\n\nmodule Publish_commitment : sig\n (** A \"publish slot header\" operation contains\n\n - a [slot_index] which is the slot index associated with the\n commitment.\n\n - a [commitment] which is a commitment to the slot data published\n onto the DAL\n\n - a [commitment_proof] which aims to prove that the size\n of the slot data does not exceed a limit set by the\n protocol. *)\n type t = {\n slot_index : Dal_slot_index_repr.t;\n commitment : Dal_slot_repr.Commitment.t;\n commitment_proof : Dal_slot_repr.Commitment_proof.t;\n }\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n (** [slot_header ~cryptobox ~number_of_slots ~current_level\n operation] constructs a valid slot header. This function can fail\n in the following cases:\n\n - The [published_level] is not equal to [current_level]\n\n - The [commitment_proof] is invalid\n\n - The [slot_index] is invalid *)\n val slot_header :\n cryptobox:Dal.t ->\n number_of_slots:int ->\n current_level:Raw_level_repr.t ->\n t ->\n Dal_slot_repr.Header.t tzresult\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 Publish_commitment = struct\n type t = {\n slot_index : Dal_slot_index_repr.t;\n commitment : Dal_slot_repr.Commitment.t;\n commitment_proof : Dal_slot_repr.Commitment_proof.t;\n }\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {slot_index; commitment; commitment_proof} ->\n (slot_index, commitment, commitment_proof))\n (fun (slot_index, commitment, commitment_proof) ->\n {slot_index; commitment; commitment_proof})\n (obj3\n (req \"slot_index\" Dal_slot_index_repr.encoding)\n (req \"commitment\" Dal_slot_repr.Commitment.encoding)\n (req \"commitment_proof\" Dal_slot_repr.Commitment_proof.encoding))\n\n let pp fmt {slot_index; commitment; commitment_proof = _} =\n Format.fprintf\n fmt\n \"slot_index: %a, commitment: %a\"\n Dal_slot_index_repr.pp\n slot_index\n Dal.Commitment.pp\n commitment\n\n let slot_header ~cryptobox ~number_of_slots ~current_level\n ({slot_index; commitment; commitment_proof} as operation) =\n let open Result_syntax in\n let* max_slot_index =\n Dal_slot_index_repr.of_int ~number_of_slots (number_of_slots - 1)\n in\n let* () =\n error_unless\n Compare.Int.(\n Dal_slot_index_repr.compare slot_index max_slot_index <= 0\n && Dal_slot_index_repr.compare slot_index Dal_slot_index_repr.zero\n >= 0)\n (Dal_errors_repr.Dal_publish_commitment_invalid_index\n {given = slot_index; maximum = max_slot_index})\n in\n let* proof_ok =\n Dal_slot_repr.Header.verify_commitment\n cryptobox\n operation.commitment\n operation.commitment_proof\n in\n let* () =\n error_unless\n proof_ok\n (Dal_errors_repr.Dal_publish_commitment_invalid_proof\n {commitment; commitment_proof})\n in\n return\n Dal_slot_repr.Header.\n {id = {published_level = current_level; index = slot_index}; commitment}\nend\n" ;
} ;
{ name = "Dal_costs_generated" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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\nval cost_Dal_publish_commitment : Gas_limit_repr.cost\n" ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model dal/Dal_publish_commitment *)\n(* max 10 1160000. *)\nlet cost_Dal_publish_commitment = S.safe_int 1160000\n" ;
} ;
{ name = "Dal_costs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 Dal_costs_generated\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 let open Result_syntax in\n Data_encoding.Binary.to_bytes_opt Origination_nonce.encoding nonce\n |> function\n | None -> tzfail Error_zk_rollup_address_generation\n | Some nonce -> return @@ 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 = 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 = 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 | Sc_rollup_bond_id id1, Sc_rollup_bond_id id2 ->\n Sc_rollup_repr.Address.compare id1 id2\nend)\n\nlet encoding =\n let open Data_encoding in\n let case = function\n | Tag tag ->\n (* The tag was used by old variant. It have been removed in\n protocol proposal O, it can be unblocked in the future. *)\n let to_tx_rollup_reserved_tag = 0 in\n assert (Compare.Int.(tag <> to_tx_rollup_reserved_tag)) ;\n case (Tag tag)\n | _ as c -> case c\n in\n def \"bond_id\"\n @@ union\n [\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)\n (fun id -> Sc_rollup_bond_id id);\n ]\n\nlet pp ppf = function 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:Sc_rollup_repr.Address.prefix id then\n match Sc_rollup_repr.Address.of_b58check_opt id with\n | Some id -> Ok (Sc_rollup_bond_id id)\n | None -> Error \"Cannot parse smart rollup id\"\n else Error \"Cannot parse rollup id\"\n\nlet construct = function\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 = "Votes_EMA_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2023 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 EMA_PARAMETERS = sig\n (* This represents the impact on the EMA of a single block\n vote. Between voting On and voting Off, the impact on the EMA is\n twice this number. *)\n val baker_contribution : Z.t\n\n (* This is the maximum value that the EMA can take. The minimal\n value cannot be set, it is 0L. *)\n val ema_max : Int32.t\nend\n\nmodule type T = 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\n\n val update_ema_up : t -> t\n\n val update_ema_down : t -> t\nend\n\nmodule Make (_ : EMA_PARAMETERS) : T\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2023 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(** Block headers contain some fields whose values represent the block\n producer's opinion on some topics. The votes are averaged to get an\n estimation of the will of the stake-weighted majority of bakers on\n these topics. The protocol can then perform automatic actions\n depending on the values of these averages; typically activating or\n deactivating some features.\n\n This module is about the computation of these averages.\n\n We use exponential moving averages (EMA for short) because they can\n easily and efficiently be implemented because a single value needs to\n be stored in the context for each average. Each EMA is updated once per\n block and stored in the context. It is represented using a 32-bit\n signed integer but it can only take non-negative values in a range\n of the form 0...ema_max where the constant ema_max, the maximum\n value of the EMA, is a parameter of this module. To update an EMA,\n we multiply the EMA computed in the previous block by a constant\n factor slightly less than 1 called the attenuation factor, and then\n we either add or remove (depending on the vote that was casted in\n the block header) another constant called the baker's contribution\n to the EMA. The baker contribution is also a parameter of this\n module. When multiplying by the attenuation factor, we round toward\n the middle of the 0...ema_max range. The update formula is thus:\n\n new_ema = ((old_ema - ema_max/2) * attenuation_factor) +- baker_contribution + ema_max/2\n\n*)\n\nmodule type EMA_PARAMETERS = sig\n val baker_contribution : Z.t\n\n val ema_max : Int32.t\n\n (* We don't need to parameterize by the attenuation factor because\n it can be computed from the two other parameters with the\n following formula:\n\n attenuation_factor = (ema_max - 2 baker_contribution) / ema_max\n *)\nend\n\nmodule type T = 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\n\n val update_ema_up : t -> t\n\n val update_ema_down : t -> t\nend\n\nmodule Make (EMA_parameters : EMA_PARAMETERS) : T = struct\n type t = Int32.t\n (* Invariant 0l <= ema <= EMA_Parameters.ema_max *)\n\n (* This error is not registered because we don't expect it to be\n raised. *)\n type error += Toggle_ema_out_of_bound of Int32.t\n\n let check_bounds x = Compare.Int32.(0l <= x && x <= EMA_parameters.ema_max)\n\n let of_int32 (x : Int32.t) : t tzresult Lwt.t =\n if check_bounds x then return x else tzfail @@ Toggle_ema_out_of_bound x\n\n let zero : t = 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 : t) : Int32.t = ema\n\n (* We perform the computations in Z to avoid overflows. *)\n\n let ema_max_z = Z.of_int32 EMA_parameters.ema_max\n\n let attenuation_numerator =\n Z.(sub ema_max_z (mul (of_int 2) EMA_parameters.baker_contribution))\n\n let attenuation_denominator = ema_max_z\n\n let attenuate z =\n Z.(div (mul attenuation_numerator z) attenuation_denominator)\n\n let half_ema_max_z = Z.(div ema_max_z (of_int 2))\n\n (* Outside of this module, the EMA is always between 0l and ema_max.\n This [recenter] wrappers, puts it in between -ema_max/2 and\n ema_max/2. The goal of this recentering around zero is to make\n [update_ema_off] and [update_ema_on] behave symmetrically with\n respect to rounding. *)\n let recenter f ema = Z.(add half_ema_max_z (f (sub ema half_ema_max_z)))\n\n let update_ema_up (ema : t) : t =\n let ema = Z.of_int32 ema in\n recenter\n (fun ema -> Z.add (attenuate ema) EMA_parameters.baker_contribution)\n ema\n |> Z.to_int32\n\n let update_ema_down (ema : t) : t =\n let ema = Z.of_int32 ema in\n recenter\n (fun ema -> Z.sub (attenuate ema) EMA_parameters.baker_contribution)\n ema\n |> Z.to_int32\n\n let ( < ) : t -> Int32.t -> bool = Compare.Int32.( < )\n\n let encoding : t Data_encoding.t =\n Data_encoding.(conv_with_guard to_int32 of_int32_for_encoding int32)\nend\n" ;
} ;
{ name = "Per_block_votes_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022-2023 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 per-block votes *)\n\ntype per_block_vote =\n | Per_block_vote_on\n | Per_block_vote_off\n | Per_block_vote_pass\n\ntype per_block_votes = {\n liquidity_baking_vote : per_block_vote;\n adaptive_issuance_vote : per_block_vote;\n}\n\nval liquidity_baking_vote_encoding : per_block_vote Data_encoding.encoding\n\nval adaptive_issuance_vote_encoding : per_block_vote Data_encoding.encoding\n\nval per_block_votes_encoding : per_block_votes Data_encoding.encoding\n\nmodule Liquidity_baking_toggle_EMA : Votes_EMA_repr.T\n\nmodule Adaptive_issuance_launch_EMA : Votes_EMA_repr.T\n\n(** [compute_new_liquidity_baking_ema ~per_block_vote old_ema] returns the value\n [new_ema] of the exponential moving average [old_ema] updated by the vote\n [per_block_vote] interpreted as a vote to deactivate the liquidity baking\n feature (Off increases the EMA).\n\n The EMA is updated as follows:\n - if [per_block_vote] is [Per_block_vote_pass] then [new_ema] = [old_ema],\n - if [per_block_vote] is [Per_block_vote_off], then [new_ema] = (1999 * ema[n] // 2000) + 1,000,000,\n - if [per_block_vote] is [Per_block_vote_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_liquidity_baking_ema :\n per_block_vote:per_block_vote ->\n Liquidity_baking_toggle_EMA.t ->\n Liquidity_baking_toggle_EMA.t\n\n(** [compute_new_adaptive_issuance_ema ~per_block_vote old_ema] returns the value\n [new_ema] of the exponential moving average [old_ema] updated by the vote\n [per_block_vote] interpreted as a vote to activate the adaptive issuance\n feature (Off decreases the EMA).\n\n The EMA is updated as follows:\n - if [per_block_vote] is [Per_block_vote_pass] then [new_ema] = [old_ema],\n - if [per_block_vote] is [Per_block_vote_off], then [new_ema] = (1999 * ema[n] // 2000),\n - if [per_block_vote] is [Per_block_vote_on], then [new_ema] = (1999 * ema[n] // 2000) + 1,000,000.\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_adaptive_issuance_ema :\n per_block_vote:per_block_vote ->\n Adaptive_issuance_launch_EMA.t ->\n Adaptive_issuance_launch_EMA.t\n\nmodule Internal_for_tests : sig\n (* Maximum value for EMA representation (both LB and AI) *)\n val ema_max : Int32.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022-2023 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 per-block votes *)\n\ntype per_block_vote =\n | Per_block_vote_on\n | Per_block_vote_off\n | Per_block_vote_pass\n\ntype per_block_votes = {\n liquidity_baking_vote : per_block_vote;\n adaptive_issuance_vote : per_block_vote;\n}\n\nlet ema_max = 2_000_000_000l\n\nlet per_block_vote_compact_encoding =\n let open Data_encoding in\n let open Compact in\n union\n ~union_tag_bits:2\n ~cases_tag_bits:0\n [\n case\n ~title:\"per_block_vote_on\"\n (payload (constant \"on\"))\n (function Per_block_vote_on -> Some () | _ -> None)\n (fun () -> Per_block_vote_on);\n case\n ~title:\"per_block_vote_off\"\n (payload (constant \"off\"))\n (function Per_block_vote_off -> Some () | _ -> None)\n (fun () -> Per_block_vote_off);\n case\n ~title:\"per_block_vote_pass\"\n (payload (constant \"pass\"))\n (function Per_block_vote_pass -> Some () | _ -> None)\n (fun () -> Per_block_vote_pass);\n ]\n\nlet liquidity_baking_vote_encoding =\n let open Data_encoding in\n def\n \"liquidity_baking_vote\"\n (Compact.make ~tag_size:`Uint8 per_block_vote_compact_encoding)\n\nlet adaptive_issuance_vote_encoding =\n let open Data_encoding in\n def\n \"adaptive_issuance_vote\"\n (Compact.make ~tag_size:`Uint8 per_block_vote_compact_encoding)\n\nlet per_block_votes_compact_encoding =\n let open Data_encoding in\n let open Compact in\n conv\n (fun {liquidity_baking_vote; adaptive_issuance_vote} ->\n (liquidity_baking_vote, adaptive_issuance_vote))\n (fun (liquidity_baking_vote, adaptive_issuance_vote) ->\n {liquidity_baking_vote; adaptive_issuance_vote})\n (obj2\n (req \"liquidity_baking_vote\" per_block_vote_compact_encoding)\n (req \"adaptive_issuance_vote\" per_block_vote_compact_encoding))\n\nlet per_block_votes_encoding =\n let open Data_encoding in\n def\n \"per_block_votes\"\n (Compact.make ~tag_size:`Uint8 per_block_votes_compact_encoding)\n\nmodule Liquidity_baking_toggle_EMA = Votes_EMA_repr.Make (struct\n let baker_contribution = Z.of_int 500_000\n\n let ema_max = ema_max\nend)\n\nmodule Adaptive_issuance_launch_EMA = Votes_EMA_repr.Make (struct\n (* The baker_contribution parameter of the adaptive issuance\n activation vote was chosen so that 2 weeks are needed to move\n the EMA from 0% to 50% when all bakers vote On.\n\n This was computed using the following formula:\n\n baker_contrib = (1/2) * ema_max * (1 - 2^(-1/k))\n\n where k is the number of blocks in 2 weeks (which is 120960).\n\n Because of a small accumulation of rounding errors, two more\n blocks are actually needed. *)\n let baker_contribution = Z.of_int 5730\n\n let ema_max = ema_max\nend)\n\nlet compute_new_liquidity_baking_ema ~per_block_vote ema =\n match per_block_vote with\n | Per_block_vote_pass -> ema\n | Per_block_vote_off -> Liquidity_baking_toggle_EMA.update_ema_up ema\n | Per_block_vote_on -> Liquidity_baking_toggle_EMA.update_ema_down ema\n\nlet compute_new_adaptive_issuance_ema ~per_block_vote ema =\n match per_block_vote with\n | Per_block_vote_pass -> ema\n | Per_block_vote_off -> Adaptive_issuance_launch_EMA.update_ema_down ema\n | Per_block_vote_on -> Adaptive_issuance_launch_EMA.update_ema_up ema\n\nmodule Internal_for_tests = struct\n let ema_max = ema_max\nend\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 per_block_votes : Per_block_votes_repr.per_block_votes;\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" ;
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 per_block_votes : Per_block_votes_repr.per_block_votes;\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 let json =\n conv\n (fun {\n payload_hash;\n payload_round;\n seed_nonce_hash;\n proof_of_work_nonce;\n per_block_votes = {liquidity_baking_vote; adaptive_issuance_vote};\n } ->\n ( payload_hash,\n payload_round,\n proof_of_work_nonce,\n seed_nonce_hash,\n liquidity_baking_vote,\n adaptive_issuance_vote ))\n (fun ( payload_hash,\n payload_round,\n proof_of_work_nonce,\n seed_nonce_hash,\n liquidity_baking_vote,\n adaptive_issuance_vote ) ->\n {\n payload_hash;\n payload_round;\n seed_nonce_hash;\n proof_of_work_nonce;\n per_block_votes = {liquidity_baking_vote; adaptive_issuance_vote};\n })\n (obj6\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 Per_block_votes_repr.liquidity_baking_vote_encoding)\n (req\n \"adaptive_issuance_vote\"\n Per_block_votes_repr.adaptive_issuance_vote_encoding))\n in\n let binary =\n conv\n (fun {\n payload_hash;\n payload_round;\n seed_nonce_hash;\n proof_of_work_nonce;\n per_block_votes;\n } ->\n ( payload_hash,\n payload_round,\n proof_of_work_nonce,\n seed_nonce_hash,\n per_block_votes ))\n (fun ( payload_hash,\n payload_round,\n proof_of_work_nonce,\n seed_nonce_hash,\n per_block_votes ) ->\n {\n payload_hash;\n payload_round;\n seed_nonce_hash;\n proof_of_work_nonce;\n per_block_votes;\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 \"per_block_votes\" Per_block_votes_repr.per_block_votes_encoding))\n in\n def \"block_header.alpha.unsigned_contents\" @@ splitted ~binary ~json\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 per_block_votes =\n {\n liquidity_baking_vote = Per_block_vote_pass;\n adaptive_issuance_vote = Per_block_vote_pass;\n };\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 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_round of {\n payload_round : Round_repr.t;\n round : Round_repr.t;\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_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.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 open Result_syntax in\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 return_unit\n else\n tzfail (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 let open Result_syntax in\n let* expected_timestamp =\n Round_repr.timestamp_of_round\n round_durations\n ~predecessor_timestamp\n ~predecessor_round\n ~round\n in\n if Time_repr.(expected_timestamp = timestamp) then return_unit\n else tzfail (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 let open Result_syntax in\n if\n check_header_proof_of_work_stamp\n block.shell\n block.protocol_data.contents\n proof_of_work_threshold\n then return_unit\n else tzfail 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 let open Result_syntax in\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 let* () =\n Proof_of_work.check_proof_of_work_stamp\n ~proof_of_work_threshold\n block_header\n in\n let* level = Raw_level_repr.of_int32 raw_level in\n let* () = check_signature block_header chain_id delegate_pk in\n let round = Fitness_repr.round fitness in\n let* () = check_payload_round ~round ~payload_round in\n let* () =\n check_timestamp\n round_durations\n ~predecessor_timestamp\n ~predecessor_round\n ~timestamp\n ~round\n in\n let* () =\n Fitness_repr.check_except_locked_round fitness ~level ~predecessor_round\n in\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" ;
} ;
{ 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 | 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 | 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 | 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 | Sc_rollup _, _ -> -1\n | _, Sc_rollup _ -> 1\nend)\n\nlet to_b58check = function\n | Contract k -> Contract_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 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 let open Result_syntax in\n match of_b58check_opt s with\n | None -> tzfail (Invalid_destination_b58check s)\n | Some dest -> return dest\n\nlet encoding =\n let open Data_encoding in\n let case = function\n | Tag tag ->\n (* The tag was used by old variant. It have been removed in\n protocol proposal O, it can be unblocked in the future. *)\n let tx_rollup_address_reserved_tag = 2 in\n assert (Compare.Int.(tag <> tx_rollup_address_reserved_tag)) ;\n case (Tag tag)\n | _ as c -> case c\n 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 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 | 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 | 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. *)\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 - preattestation\n - attestation\n - double baking evidence\n - double preattestation evidence\n - double attestation 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 - smart rollup origination\n - smart rollup add messages\n - smart rollup publish\n - smart rollup cement\n - smart rollup refute\n - smart rollup timeout\n - smart rollup execute outbox message\n - smart rollup recover bond\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 preattestation_consensus_kind = Preattestation_consensus_kind\n\n type attestation_consensus_kind = Attestation_consensus_kind\n\n type 'a consensus =\n | Preattestation_kind : preattestation_consensus_kind consensus\n | Attestation_kind : attestation_consensus_kind consensus\n\n type preattestation = preattestation_consensus_kind consensus\n\n type attestation = attestation_consensus_kind consensus\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_attestation_evidence =\n attestation_consensus_kind double_consensus_operation_evidence\n\n type double_preattestation_evidence =\n preattestation_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 transfer_ticket = Transfer_ticket_kind\n\n type dal_publish_commitment = Dal_publish_commitment_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 | Transfer_ticket_manager_kind : transfer_ticket manager\n | Dal_publish_commitment_manager_kind : dal_publish_commitment 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 | Attestation : Kind.attestation consensus_operation_type\n | Preattestation : Kind.preattestation consensus_operation_type\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)attested block. *)\n round : Round_repr.t;\n (* The round of (pre)attested block. *)\n block_payload_hash : Block_payload_hash.t;\n (* The payload hash of (pre)attested block. *)\n}\n\nval consensus_content_encoding : consensus_content Data_encoding.t\n\nval pp_consensus_content : Format.formatter -> consensus_content -> unit\n\n(** The DAL content in an attestation operation having some level [l] refers to a\n slot published at level [l - attestation_lag + 1]. Whenever there is a need\n to disambiguate, one should use \"attestation level\" for the level inside the\n operation and \"attested level\" for the level of the block including the\n operation. We have:\n - [attestation_level + 1 = attested_level]\n - [published_level + attestation_lag = attested_level] *)\ntype dal_content = {attestation : Dal_attestation_repr.t}\n\ntype consensus_watermark =\n | Attestation of Chain_id.t\n | Preattestation 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 (* Preattestation: About consensus, preattestation of a block held by a\n validator (specific to Tenderbake). *)\n | Preattestation : consensus_content -> Kind.preattestation contents\n (* Attestation: About consensus, attestation of a block held by a\n validator. *)\n | Attestation : {\n consensus_content : consensus_content;\n dal_content : dal_content option;\n }\n -> Kind.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_preattestation_evidence: Double-preattestation is a\n kind of malicious attack where a byzantine attempts to fork\n the chain by preattesting 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_preattestation_evidence : {\n op1 : Kind.preattestation operation;\n op2 : Kind.preattestation operation;\n }\n -> Kind.double_preattestation_evidence contents\n (* Double_attestation_evidence: Similar to double-preattestation but\n for attestations. *)\n | Double_attestation_evidence : {\n op1 : Kind.attestation operation;\n op2 : Kind.attestation operation;\n }\n -> Kind.double_attestation_evidence contents\n (* Double_baking_evidence: Similarly to double-attestation 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.t;\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.t;\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.t;\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 (** [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_commitment :\n Dal_operations_repr.Publish_commitment.t\n -> Kind.dal_publish_commitment 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 parameters_ty : Script_repr.lazy_expr;\n whitelist : Sc_rollup_whitelist_repr.t option;\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 }\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\n(** Operation encoding that accepts legacy attestation name : `endorsement`\n (and preendorsement, double_<op>_evidence) in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements kinds\n in JSON will not be accepted any more by the protocol.\n*)\nval encoding_with_legacy_attestation_name : packed_operation Data_encoding.t\n\nval contents_encoding : packed_contents Data_encoding.t\n\nval contents_encoding_with_legacy_attestation_name :\n packed_contents Data_encoding.t\n\nval contents_list_encoding : packed_contents_list Data_encoding.t\n\nval contents_list_encoding_with_legacy_attestation_name :\n packed_contents_list Data_encoding.t\n\nval protocol_data_encoding : packed_protocol_data Data_encoding.t\n\nval protocol_data_encoding_with_legacy_attestation_name :\n packed_protocol_data Data_encoding.t\n\nval unsigned_operation_encoding :\n (Operation.shell_header * packed_contents_list) Data_encoding.t\n\nval unsigned_operation_encoding_with_legacy_attestation_name :\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 {!Attestation} and {!Preattestation} >\n {!Proposals} > {!Ballot} > {!Double_preattestation_evidence} >\n {!Double_attestation_evidence} > {!Double_baking_evidence} >\n {!Vdf_revelation} > {!Seed_nonce_revelation} > {!Activate_account}\n > {!Drain_delegate} > {!Manager_operation}.\n\n {!Attestation} and {!Preattestation} are compared by the pair of their\n [level] and [round] such as the farther to the current state [level] and\n [round] is greater; e.g. the greater pair in lexicographic order being the\n better. When equal and both operations being of the same kind, we compare\n their [slot], the smaller being the better (assuming that the more slots an\n attester has, the smaller is its smallest [slot]), and then the number of the\n DAL attested slots, the more the better. When the pair is equal and comparing\n an {!Attestation} to a {!Preattestation}, the {!Attestation} is better.\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\n(** Measuring the length of an operation, ignoring its signature.\n This is useful to define a gas model for the check of the\n signature. *)\nval unsigned_operation_length : _ operation -> int\n\n(** Check the signature of an operation. This function serializes the\n operation before calling the [Signature.check] function with the\n appropriate watermark. *)\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.preattestation case\n\n val preattestation_case : Kind.preattestation case\n\n val endorsement_case : Kind.attestation case\n\n val attestation_case : Kind.attestation case\n\n val endorsement_with_dal_case : Kind.attestation case\n\n val attestation_with_dal_case : Kind.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_preattestation_evidence case\n\n val double_preattestation_evidence_case :\n Kind.double_preattestation_evidence case\n\n val double_endorsement_evidence_case : Kind.double_attestation_evidence case\n\n val double_attestation_evidence_case : Kind.double_attestation_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 transfer_ticket_case : Kind.transfer_ticket Kind.manager case\n\n val dal_publish_commitment_case :\n Kind.dal_publish_commitment 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 transfer_ticket_case : Kind.transfer_ticket case\n\n val dal_publish_commitment_case : Kind.dal_publish_commitment 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\nmodule Internal_for_benchmarking : sig\n (* Serialize an operation, ignoring its signature. *)\n val serialize_unsigned_operation : _ operation -> bytes\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 preattestation_consensus_kind = Preattestation_consensus_kind\n\n type attestation_consensus_kind = Attestation_consensus_kind\n\n type 'a consensus =\n | Preattestation_kind : preattestation_consensus_kind consensus\n | Attestation_kind : attestation_consensus_kind consensus\n\n type preattestation = preattestation_consensus_kind consensus\n\n type attestation = attestation_consensus_kind consensus\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_attestation_evidence =\n attestation_consensus_kind double_consensus_operation_evidence\n\n type double_preattestation_evidence =\n preattestation_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 transfer_ticket = Transfer_ticket_kind\n\n type dal_publish_commitment = Dal_publish_commitment_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 | Transfer_ticket_manager_kind : transfer_ticket manager\n | Dal_publish_commitment_manager_kind : dal_publish_commitment 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 | Attestation : Kind.attestation consensus_operation_type\n | Preattestation : Kind.preattestation consensus_operation_type\n\ntype consensus_content = {\n slot : Slot_repr.t;\n level : Raw_level_repr.t;\n (* The level is not required to validate an attestation when it corresponds\n to the current payload, but if we want to filter attestations, 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\ntype dal_content = {attestation : Dal_attestation_repr.t}\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 | Attestation of Chain_id.t\n | Preattestation of Chain_id.t\n\nlet to_watermark = function\n | Preattestation chain_id ->\n Signature.Custom\n (Bytes.cat (Bytes.of_string \"\\x12\") (Chain_id.to_bytes chain_id))\n | Attestation chain_id ->\n Signature.Custom\n (Bytes.cat (Bytes.of_string \"\\x13\") (Chain_id.to_bytes chain_id))\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 -> Preattestation 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 -> 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 | Preattestation : consensus_content -> Kind.preattestation contents\n | Attestation : {\n consensus_content : consensus_content;\n dal_content : dal_content option;\n }\n -> Kind.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_preattestation_evidence : {\n op1 : Kind.preattestation operation;\n op2 : Kind.preattestation operation;\n }\n -> Kind.double_preattestation_evidence contents\n | Double_attestation_evidence : {\n op1 : Kind.attestation operation;\n op2 : Kind.attestation operation;\n }\n -> Kind.double_attestation_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.t;\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.t;\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.t;\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 | 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_commitment :\n Dal_operations_repr.Publish_commitment.t\n -> Kind.dal_publish_commitment manager_operation\n | Sc_rollup_originate : {\n kind : Sc_rollups.Kind.t;\n boot_sector : string;\n parameters_ty : Script_repr.lazy_expr;\n whitelist : Sc_rollup_whitelist_repr.t option;\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 }\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 | Transfer_ticket _ -> Kind.Transfer_ticket_manager_kind\n | Dal_publish_commitment _ -> Kind.Dal_publish_commitment_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 -> Result_syntax.tzfail @@ 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\n(** The following operation tags cannot be used again, it is checked\n at compilation time. *)\nlet tx_rollup_forbidden_operation_tags =\n [\n tx_rollup_operation_origination_tag;\n tx_rollup_operation_submit_batch_tag;\n tx_rollup_operation_commit_tag;\n tx_rollup_operation_return_bond_tag;\n tx_rollup_operation_finalize_commitment_tag;\n tx_rollup_operation_remove_commitment_tag;\n tx_rollup_operation_rejection_tag;\n tx_rollup_operation_dispatch_tickets_tag;\n ]\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_commitment_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 can not be used yet for operations. *)\n let reserved_tag t =\n (* These tags are reserved for future extensions: [fd] - [ff]. *)\n Compare.Int.(t >= 0xfd)\n || (* These tags were used by old operations.\n The operations have been removed in protocol proposal N, it can\n be unblocked in the future (e.g. proposal O, P etc.). *)\n List.exists (Compare.Int.equal t) tx_rollup_forbidden_operation_tags\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 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 \"parameters_ty\" Script_repr.lazy_expr_encoding)\n (opt \"whitelist\" Sc_rollup_whitelist_repr.encoding);\n select =\n (function\n | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_originate {kind; boot_sector; parameters_ty; whitelist}\n ->\n (kind, boot_sector, parameters_ty, whitelist));\n inj =\n (fun (kind, boot_sector, parameters_ty, whitelist) ->\n Sc_rollup_originate {kind; boot_sector; parameters_ty; whitelist});\n }\n\n let dal_publish_commitment_case =\n MCase\n {\n tag = dal_publish_commitment_tag;\n name = \"dal_publish_commitment\";\n encoding =\n obj1\n (req\n \"slot_header\"\n Dal_operations_repr.Publish_commitment.encoding);\n select =\n (function\n | Manager (Dal_publish_commitment _ as op) -> Some op | _ -> None);\n proj = (function Dal_publish_commitment slot_header -> slot_header);\n inj = (fun slot_header -> Dal_publish_commitment 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 = obj1 (req \"rollup\" Sc_rollup_repr.encoding);\n select =\n (function\n | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None);\n proj = (function Sc_rollup_cement {rollup} -> rollup);\n inj = (fun rollup -> Sc_rollup_cement {rollup});\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 (* Encoding case that accepts legacy preattestation name : `preendorsement` in\n JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\n let preendorsement_case =\n Case\n {\n tag = 20;\n name = \"preendorsement\";\n encoding = consensus_content_encoding;\n select =\n (function Contents (Preattestation _ as op) -> Some op | _ -> None);\n proj = (fun (Preattestation preattestation) -> preattestation);\n inj = (fun preattestation -> Preattestation preattestation);\n }\n\n let preattestation_case =\n Case\n {\n tag = 20;\n name = \"preattestation\";\n encoding = consensus_content_encoding;\n select =\n (function Contents (Preattestation _ as op) -> Some op | _ -> None);\n proj = (fun (Preattestation preattestation) -> preattestation);\n inj = (fun preattestation -> Preattestation preattestation);\n }\n\n (* Encoding that accepts legacy preattestation name : `preendorsement` in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\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.preattestation contents_list -> _ = function\n | Single o -> o\n in\n let of_list : Kind.preattestation 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 preattestation_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.preattestation contents_list -> _ = function\n | Single o -> o\n in\n let of_list : Kind.preattestation contents -> _ = function\n | o -> Single o\n in\n def \"inlined.preattestation\"\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.preattestation.contents\"\n @@ union [make preattestation_case]))\n (varopt \"signature\" Signature.encoding)))\n\n let consensus_content_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 dal_content_encoding =\n obj1 (req \"dal_attestation\" Dal_attestation_repr.encoding)\n\n let endorsement_encoding = consensus_content_encoding\n\n let endorsement_with_dal_encoding =\n merge_objs consensus_content_encoding dal_content_encoding\n\n (* Precondition: [dal_content = None]. *)\n let attestation_encoding_proj\n (Attestation {consensus_content; dal_content = _}) =\n ( consensus_content.slot,\n consensus_content.level,\n consensus_content.round,\n consensus_content.block_payload_hash )\n\n let attestation_encoding_inj (slot, level, round, block_payload_hash) =\n Attestation\n {\n consensus_content = {slot; level; round; block_payload_hash};\n dal_content = None;\n }\n\n (* Precondition: [dal_content <> None]. Check usage! *)\n let attestation_with_dal_encoding_proj\n (Attestation {consensus_content; dal_content}) =\n match dal_content with\n | None -> assert false\n | Some dal_content ->\n ( ( consensus_content.slot,\n consensus_content.level,\n consensus_content.round,\n consensus_content.block_payload_hash ),\n dal_content.attestation )\n\n let attestation_with_dal_encoding_inj\n ((slot, level, round, block_payload_hash), attestation) =\n Attestation\n {\n consensus_content = {slot; level; round; block_payload_hash};\n dal_content = Some {attestation};\n }\n\n (* Encoding case that accepts legacy attestation name : `endorsement` in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\n let endorsement_case =\n Case\n {\n tag = 21;\n name = \"endorsement\";\n encoding = endorsement_encoding;\n select =\n (function\n | Contents (Attestation {dal_content = None; _} as op) -> Some op\n | _ -> None);\n proj = attestation_encoding_proj;\n inj = attestation_encoding_inj;\n }\n\n let attestation_case =\n Case\n {\n tag = 21;\n name = \"attestation\";\n encoding = endorsement_encoding;\n select =\n (function\n | Contents (Attestation {dal_content = None; _} as op) -> Some op\n | _ -> None);\n proj = attestation_encoding_proj;\n inj = attestation_encoding_inj;\n }\n\n let endorsement_with_dal_case =\n Case\n {\n tag = 23;\n name = \"endorsement_with_dal\";\n encoding = endorsement_with_dal_encoding;\n select =\n (function\n | Contents (Attestation {dal_content = Some _; _} as op) -> Some op\n | _ -> None);\n proj = attestation_with_dal_encoding_proj;\n inj = attestation_with_dal_encoding_inj;\n }\n\n let attestation_with_dal_case =\n Case\n {\n tag = 23;\n name = \"attestation_with_dal\";\n encoding = endorsement_with_dal_encoding;\n select =\n (function\n | Contents (Attestation {dal_content = Some _; _} as op) -> Some op\n | _ -> None);\n proj = attestation_with_dal_encoding_proj;\n inj = attestation_with_dal_encoding_inj;\n }\n\n (* Encoding that accepts legacy attestation name : `endorsement` in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\n let endorsement_encoding =\n let make kind (Case {tag; name; encoding; select = _; proj; inj}) =\n case\n (Tag tag)\n name\n encoding\n (function\n | o -> (\n match (kind, o) with\n | `Simple, (Attestation {dal_content = None; _} as op) ->\n Some (proj op)\n | `Full, (Attestation {dal_content = Some _; _} as op) ->\n Some (proj op)\n | _ -> None))\n (fun x -> inj x)\n in\n let to_list : Kind.attestation contents_list -> _ = fun (Single o) -> o in\n let of_list : Kind.attestation 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\n [\n make `Simple endorsement_case;\n make `Full endorsement_with_dal_case;\n ]))\n (varopt \"signature\" Signature.encoding)))\n\n let attestation_encoding =\n let make kind (Case {tag; name; encoding; select = _; proj; inj}) =\n case\n (Tag tag)\n name\n encoding\n (function\n | o -> (\n match (kind, o) with\n | `Without_dal, (Attestation {dal_content = None; _} as op) ->\n Some (proj op)\n | `With_dal, (Attestation {dal_content = Some _; _} as op) ->\n Some (proj op)\n | _ -> None))\n (fun x -> inj x)\n in\n let to_list : Kind.attestation contents_list -> _ = fun (Single o) -> o in\n let of_list : Kind.attestation contents -> _ = fun o -> Single o in\n def \"inlined.attestation\"\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.attestation_mempool.contents\"\n @@ union\n [\n make `Without_dal attestation_case;\n make `With_dal attestation_with_dal_case;\n ]))\n (varopt \"signature\" Signature.encoding)))\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 (* Encoding case that accepts legacy double preattestation evidence name :\n `double_preendorsement_evidence` in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\n let double_preendorsement_evidence_case :\n Kind.double_preattestation_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_preattestation_evidence _ as op) -> Some op\n | _ -> None);\n proj = (fun (Double_preattestation_evidence {op1; op2}) -> (op1, op2));\n inj = (fun (op1, op2) -> Double_preattestation_evidence {op1; op2});\n }\n\n let double_preattestation_evidence_case :\n Kind.double_preattestation_evidence case =\n Case\n {\n tag = 7;\n name = \"double_preattestation_evidence\";\n encoding =\n obj2\n (req \"op1\" (dynamic_size preattestation_encoding))\n (req \"op2\" (dynamic_size preattestation_encoding));\n select =\n (function\n | Contents (Double_preattestation_evidence _ as op) -> Some op\n | _ -> None);\n proj = (fun (Double_preattestation_evidence {op1; op2}) -> (op1, op2));\n inj = (fun (op1, op2) -> Double_preattestation_evidence {op1; op2});\n }\n\n (* Encoding case that accepts legacy double attestation evidence name :\n `double_endorsement_evidence` in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\n let double_endorsement_evidence_case : Kind.double_attestation_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_attestation_evidence _ as op) -> Some op\n | _ -> None);\n proj = (fun (Double_attestation_evidence {op1; op2}) -> (op1, op2));\n inj = (fun (op1, op2) -> Double_attestation_evidence {op1; op2});\n }\n\n let double_attestation_evidence_case : Kind.double_attestation_evidence case =\n Case\n {\n tag = 2;\n name = \"double_attestation_evidence\";\n encoding =\n obj2\n (req \"op1\" (dynamic_size attestation_encoding))\n (req \"op2\" (dynamic_size attestation_encoding));\n select =\n (function\n | Contents (Double_attestation_evidence _ as op) -> Some op\n | _ -> None);\n proj = (fun (Double_attestation_evidence {op1; op2}) -> (op1, op2));\n inj = (fun (op1, op2) -> Double_attestation_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 transfer_ticket_case =\n make_manager_case\n transfer_ticket_tag\n Manager_operations.transfer_ticket_case\n\n let dal_publish_commitment_case =\n make_manager_case\n dal_publish_commitment_tag\n Manager_operations.dal_publish_commitment_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 common_cases =\n [\n PCase seed_nonce_revelation_case;\n PCase vdf_revelation_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 transfer_ticket_case;\n PCase dal_publish_commitment_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_cases =\n PCase preattestation_case :: PCase attestation_case\n :: PCase attestation_with_dal_case\n :: PCase double_preattestation_evidence_case\n :: PCase double_attestation_evidence_case :: common_cases\n\n (** Encoding cases that accepts legacy attestation name : `endorsement` (and\n preendorsement, double_<op>_evidence) in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements\n kinds in JSON will not be accepted any more by the protocol (Planned for\n protocol Q). *)\n let contents_cases_with_legacy_attestation_name =\n PCase preendorsement_case :: PCase endorsement_case\n :: PCase endorsement_with_dal_case\n :: PCase double_preendorsement_evidence_case\n :: PCase double_endorsement_evidence_case :: common_cases\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_encoding_with_legacy_attestation_name =\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_with_legacy_attestation_name.alpha.contents\"\n @@ union (List.map make contents_cases_with_legacy_attestation_name)\n\n let contents_list_encoding =\n conv_with_guard to_list of_list_internal (Variable.list contents_encoding)\n\n let contents_list_encoding_with_legacy_attestation_name =\n conv_with_guard\n to_list\n of_list_internal\n (Variable.list contents_encoding_with_legacy_attestation_name)\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 let protocol_data_json_encoding_with_legacy_attestation_name =\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\n \"contents\"\n (dynamic_size contents_list_encoding_with_legacy_attestation_name))\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 let open Result_syntax in\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* 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 protocol_data_encoding_with_legacy_attestation_name =\n def \"operation_with_legacy_attestation_name.alpha.contents_and_signature\"\n @@ splitted\n ~json:protocol_data_json_encoding_with_legacy_attestation_name\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 operation_encoding_with_legacy_attestation_name =\n conv\n (fun {shell; protocol_data} -> (shell, protocol_data))\n (fun (shell, protocol_data) -> {shell; protocol_data})\n (merge_objs\n Operation.shell_header_encoding\n protocol_data_encoding_with_legacy_attestation_name)\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))\n\n let unsigned_operation_encoding_with_legacy_attestation_name =\n def \"operation_with_legacy_attestation_name.alpha.unsigned_operation\"\n @@ merge_objs\n Operation.shell_header_encoding\n (obj1\n (req \"contents\" contents_list_encoding_with_legacy_attestation_name))\nend\n\nlet encoding = Encoding.operation_encoding\n\nlet encoding_with_legacy_attestation_name =\n Encoding.operation_encoding_with_legacy_attestation_name\n\nlet contents_encoding = Encoding.contents_encoding\n\nlet contents_encoding_with_legacy_attestation_name =\n Encoding.contents_encoding_with_legacy_attestation_name\n\nlet contents_list_encoding = Encoding.contents_list_encoding\n\nlet contents_list_encoding_with_legacy_attestation_name =\n Encoding.contents_list_encoding_with_legacy_attestation_name\n\nlet protocol_data_encoding = Encoding.protocol_data_encoding\n\nlet protocol_data_encoding_with_legacy_attestation_name =\n Encoding.protocol_data_encoding_with_legacy_attestation_name\n\nlet unsigned_operation_encoding = Encoding.unsigned_operation_encoding\n\nlet unsigned_operation_encoding_with_legacy_attestation_name =\n Encoding.unsigned_operation_encoding_with_legacy_attestation_name\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 (Preattestation _) -> Some consensus_pass\n | Single (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_attestation_evidence _) -> Some anonymous_pass\n | Single (Double_preattestation_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 serialize_unsigned_operation (type kind)\n ({shell; protocol_data} : kind operation) : bytes =\n Data_encoding.Binary.to_bytes_exn\n unsigned_operation_encoding\n (shell, Contents_list protocol_data.contents)\n\nlet unsigned_operation_length (type kind)\n ({shell; protocol_data} : kind operation) : int =\n Data_encoding.Binary.length\n unsigned_operation_encoding\n (shell, Contents_list protocol_data.contents)\n\nlet check_signature (type kind) key chain_id (op : kind operation) =\n let open Result_syntax in\n let serialized_operation = serialize_unsigned_operation op in\n let check ~watermark signature =\n if Signature.check ~watermark key signature serialized_operation then\n return_unit\n else tzfail Invalid_signature\n in\n match op.protocol_data.signature with\n | None -> tzfail Missing_signature\n | Some signature ->\n let watermark =\n match op.protocol_data.contents with\n | Single (Preattestation _) -> to_watermark (Preattestation chain_id)\n | Single (Attestation _) -> to_watermark (Attestation chain_id)\n | Single\n ( Failing_noop _ | Proposals _ | Ballot _ | Seed_nonce_revelation _\n | Vdf_revelation _ | Double_attestation_evidence _\n | Double_preattestation_evidence _ | Double_baking_evidence _\n | Activate_account _ | Drain_delegate _ | Manager_operation _ ) ->\n Generic_operation\n | Cons (Manager_operation _, _ops) -> Generic_operation\n in\n check ~watermark 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 | Transfer_ticket _, Transfer_ticket _ -> Some Eq\n | Transfer_ticket _, _ -> None\n | Dal_publish_commitment _, Dal_publish_commitment _ -> Some Eq\n | Dal_publish_commitment _, _ -> 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 | Preattestation _, Preattestation _ -> Some Eq\n | Preattestation _, _ -> None\n | Attestation _, Attestation _ -> Some Eq\n | 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_attestation_evidence _, Double_attestation_evidence _ -> Some Eq\n | Double_attestation_evidence _, _ -> None\n | Double_preattestation_evidence _, Double_preattestation_evidence _ ->\n Some Eq\n | Double_preattestation_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(** [preattestation_infos] is the pair of a {!round_infos} and a [slot]\n convert into an {!int}. *)\ntype preattestation_infos = {round : round_infos; slot : int}\n\n(** [attestation_infos] is the tuple consisting of a {!round_infos} value, a\n [slot], and the number of DAL slots in the DAL attestation. *)\ntype attestation_infos = {\n round_infos : round_infos;\n slot : int;\n number_of_dal_attested_slots : int;\n}\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 {!attestation_infos} from a {!consensus_content}. It is\n used to compute the weight of {!Attestation} and {!Preattestation}.\n\n Precondition: [c] comes from a valid operation. The {!Attestation}\n or {!Preattestation} 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 attestation_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 {!attestation_infos} value from a {!consensus_content} value\n and an optional {!dal_content} value. It is used to compute the weight of\n an {!Attestation}.\n\n An {!Attestation} with no DAL content or with a DAL content that has 0\n attested DAL slots have the same weight (everything else being\n equal). That's ok, because they are semantically equal, therefore it\n does not matter which one is picked.\n\n Precondition: [c] and [d] come from a valid operation. *)\nlet attestation_infos_from_content (c : consensus_content)\n (d : dal_content option) =\n let slot = Slot_repr.to_int c.slot in\n let round_infos = round_infos_from_consensus_content c in\n {\n round_infos;\n slot;\n number_of_dal_attested_slots =\n Option.fold\n ~none:0\n ~some:(fun d ->\n Dal_attestation_repr.number_of_attested_slots d.attestation)\n d;\n }\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 {!Attestation} or {!Preattestation} depends on its\n {!attestation_infos}. For {!Attestation}s it also depends on the number of\n attested DAL slots.\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_preattestation} or\n {!Double_attestation} 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_attestation : attestation_infos -> consensus_pass_type weight\n | Weight_preattestation : preattestation_infos -> 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_preattestation : round_infos -> anonymous_pass_type weight\n | Weight_double_attestation : 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 (Preattestation consensus_content) ->\n W\n ( Consensus,\n Weight_preattestation\n (attestation_infos_from_consensus_content consensus_content) )\n | Single (Attestation {consensus_content; dal_content}) ->\n W\n ( Consensus,\n Weight_attestation\n (attestation_infos_from_content consensus_content dal_content) )\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_attestation_evidence {op1; _}) -> (\n match op1.protocol_data.contents with\n | Single (Attestation {consensus_content; dal_content = _}) ->\n W\n ( Anonymous,\n Weight_double_attestation\n (round_infos_from_consensus_content consensus_content) ))\n | Single (Double_preattestation_evidence {op1; _}) -> (\n match op1.protocol_data.contents with\n | Single (Preattestation consensus_content) ->\n W\n ( Anonymous,\n Weight_double_preattestation\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} pairs [(level, round)] compare 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 better {!round_infos} is farther to the current state\n when part of the weight of a valid consensus operation.\n\n The better {!round_infos} is nearer to the current state when\n part of the weight of a valid denunciation.\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 : round_infos) (infos2 : round_infos) =\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(** Two {!Preattestation}s are compared by their {!preattestation_infos}.\n When their {!round_infos} are equal, they are compared according to\n their [slot]: the smaller the better. *)\nlet compare_preattestation_infos (infos1 : preattestation_infos)\n (infos2 : preattestation_infos) =\n compare_pair_in_lexico_order\n ~cmp_fst:compare_round_infos\n ~cmp_snd:(compare_reverse Compare.Int.compare)\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 {!Attestation}s are compared by their {!attestation_infos}. When their\n {!round_infos} are equal, they are compared according to their [slot]: the\n smaller the better. When the slots are also equal they are compared\n according to the number of attested DAL slots: the more the better. *)\nlet compare_attestation_infos\n {round_infos = infos1; slot = slot1; number_of_dal_attested_slots = n1}\n {round_infos = infos2; slot = slot2; number_of_dal_attested_slots = n2} =\n compare_pair_in_lexico_order\n ~cmp_fst:\n (compare_pair_in_lexico_order\n ~cmp_fst:compare_round_infos\n ~cmp_snd:(compare_reverse Compare.Int.compare))\n ~cmp_snd:Compare.Int.compare\n ((infos1, slot1), n1)\n ((infos2, slot2), n2)\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 comparison on\n {!attestation_infos} for {!Attestation}s and {!Preattestation}s. In case of\n equality of their {!round_infos}, either they are of the same kind and their\n [slot]s have to be compared in the reverse order, otherwise the\n {!Attestation}s are better. In case of {!Attestation}s, the number of\n attested DAL slots is taken into account when all else is equal.\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_attestation infos1, Weight_attestation infos2 ->\n compare_attestation_infos infos1 infos2\n | Weight_preattestation infos1, Weight_preattestation infos2 ->\n compare_preattestation_infos infos1 infos2\n | ( Weight_attestation {round_infos = round_infos1; _},\n Weight_preattestation {round = round_infos2; _} ) ->\n let cmp = compare_round_infos round_infos1 round_infos2 in\n if Compare.Int.(cmp <> 0) then cmp else 1\n | ( Weight_preattestation {round = round_infos1; _},\n Weight_attestation {round_infos = round_infos2; _} ) ->\n let cmp = compare_round_infos round_infos1 round_infos2 in\n if Compare.Int.(cmp <> 0) then cmp else -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_attestation_evidence}, or two\n {!Double_preattestation_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_preattestation_evidence} >\n {!Double_attestation_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_preattestation infos1, Weight_double_preattestation infos2 ->\n compare_round_infos infos1 infos2\n | Weight_double_preattestation infos1, Weight_double_attestation infos2 ->\n let cmp = compare_round_infos infos1 infos2 in\n if Compare.Int.(cmp <> 0) then cmp else 1\n | Weight_double_attestation infos1, Weight_double_preattestation infos2 ->\n let cmp = compare_round_infos infos1 infos2 in\n if Compare.Int.(cmp <> 0) then cmp else -1\n | Weight_double_attestation infos1, Weight_double_attestation 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_preattestation _ | Weight_double_attestation _) ) ->\n -1\n | ( (Weight_double_preattestation _ | Weight_double_attestation _),\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\nmodule Internal_for_benchmarking = struct\n let serialize_unsigned_operation = serialize_unsigned_operation\nend\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 contract store is updated with the public key\n 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 hash : Contract_hash.t option;\n (** If the contract hash is not provided, generate a fresh hash. *)\n}\n\n(** An originated smart rollup initially existing on a chain since genesis. *)\ntype bootstrap_smart_rollup = {\n address : Sc_rollup_repr.Address.t;\n pvm_kind : Sc_rollups.Kind.t;\n boot_sector : string;\n parameters_ty : Script_repr.lazy_expr;\n whitelist : Sc_rollup_whitelist_repr.t option;\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 bootstrap_smart_rollups : bootstrap_smart_rollup 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 hash : Contract_hash.t option;\n}\n\ntype bootstrap_smart_rollup = {\n address : Sc_rollup_repr.Address.t;\n pvm_kind : Sc_rollups.Kind.t;\n boot_sector : string;\n parameters_ty : Script_repr.lazy_expr;\n whitelist : Sc_rollup_whitelist_repr.t option;\n}\n\ntype t = {\n bootstrap_accounts : bootstrap_account list;\n bootstrap_contracts : bootstrap_contract list;\n bootstrap_smart_rollups : bootstrap_smart_rollup 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; hash} -> (delegate, amount, script, hash))\n (fun (delegate, amount, script, hash) -> {delegate; amount; script; hash})\n (obj4\n (opt \"delegate\" Signature.Public_key_hash.encoding)\n (req \"amount\" Tez_repr.encoding)\n (req \"script\" Script_repr.encoding)\n (opt \"hash\" Contract_hash.encoding))\n\nlet bootstrap_smart_rollup_encoding =\n let open Data_encoding in\n conv\n (fun {address; pvm_kind; boot_sector; parameters_ty; whitelist} ->\n (address, pvm_kind, boot_sector, parameters_ty, whitelist))\n (fun (address, pvm_kind, boot_sector, parameters_ty, whitelist) ->\n {address; pvm_kind; boot_sector; parameters_ty; whitelist})\n (obj5\n (req \"address\" Sc_rollup_repr.Address.encoding)\n (req \"pvm_kind\" Sc_rollups.Kind.encoding)\n (req \"kernel\" (string Hex))\n (req \"parameters_ty\" Script_repr.lazy_expr_encoding)\n (opt \"whitelist\" Sc_rollup_whitelist_repr.encoding))\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {\n bootstrap_accounts;\n bootstrap_contracts;\n bootstrap_smart_rollups;\n commitments;\n constants;\n security_deposit_ramp_up_cycles;\n no_reward_cycles;\n } ->\n ( ( bootstrap_accounts,\n bootstrap_contracts,\n bootstrap_smart_rollups,\n commitments,\n security_deposit_ramp_up_cycles,\n no_reward_cycles ),\n constants ))\n (fun ( ( bootstrap_accounts,\n bootstrap_contracts,\n bootstrap_smart_rollups,\n commitments,\n security_deposit_ramp_up_cycles,\n no_reward_cycles ),\n constants ) ->\n {\n bootstrap_accounts;\n bootstrap_contracts;\n bootstrap_smart_rollups;\n commitments;\n constants;\n security_deposit_ramp_up_cycles;\n no_reward_cycles;\n })\n (merge_objs\n (obj6\n (req \"bootstrap_accounts\" (list bootstrap_account_encoding))\n (dft \"bootstrap_contracts\" (list bootstrap_contract_encoding) [])\n (dft\n \"bootstrap_smart_rollups\"\n (list bootstrap_smart_rollup_encoding)\n [])\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 let open Lwt_syntax in\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\n let* acc = f acc id in\n 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 = "Full_staking_balance_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype t\n\nval init :\n own_frozen:Tez_repr.t ->\n staked_frozen:Tez_repr.t ->\n delegated:Tez_repr.t ->\n current_level:Level_repr.t ->\n t\n\nval encoding : t Data_encoding.t\n\n(** The weight of a delegate used for voting rights. *)\nval voting_weight : t -> Int64.t tzresult\n\nval apply_slashing : percentage:Percentage.t -> t -> t\n\n(** The delegate's own frozen funds. *)\nval own_frozen : t -> Tez_repr.t\n\n(** The total frozen funds from all external stakers.\n\n Does not take the [limit_of_staking_over_baking] into account. *)\nval staked_frozen : t -> Tez_repr.t\n\n(** The total delegated funds from all delegators.\n\n Not adjusted considering overdelegation / overstaking. *)\nval current_delegated : t -> Tez_repr.t\n\nval min_delegated_in_cycle : current_cycle:Cycle_repr.t -> t -> Tez_repr.t\n\n(** Sum of [own_frozen] and [staked_frozen]. *)\nval total_frozen : t -> Tez_repr.t tzresult\n\n(** Sum of [own_frozen], [staked_frozen], and [current_delegated]. *)\nval current_total : t -> Tez_repr.t tzresult\n\n(** The portion of {!staked_frozen} that actually counts as staking\n when computing baking rights, considering both the global and the\n delegate's [limit_of_staking_over_baking].\n\n It is equal to the minimum of:\n\n - {!staked_frozen}\n\n - {!own_frozen} scaled by the delegate's [limit_of_staking_over_baking]\n\n - {!own_frozen} scaled by the global [limit_of_staking_over_baking] *)\nval allowed_staked_frozen :\n adaptive_issuance_global_limit_of_staking_over_baking:int ->\n delegate_limit_of_staking_over_baking_millionth:int32 ->\n t ->\n Tez_repr.t\n\n(** Computes [(num, den)] representing the ratio of [own_frozen] over\n [own_frozen + allowed_staked_frozen].\n\n If [allowed_staked_frozen] is zero, returns [(1L, 1L)].\n\n If [own_frozen] is zero, returns [(0L, 1L)]. *)\nval own_ratio :\n adaptive_issuance_global_limit_of_staking_over_baking:int ->\n delegate_limit_of_staking_over_baking_millionth:int32 ->\n t ->\n int64 * int64\n\nval has_minimal_frozen_stake : minimal_frozen_stake:Tez_repr.t -> t -> bool\n\nval has_minimal_stake_to_be_considered : minimal_stake:Tez_repr.t -> t -> bool\n\nval remove_delegated :\n current_level:Level_repr.t -> amount:Tez_repr.t -> t -> t tzresult\n\nval remove_own_frozen : amount:Tez_repr.t -> t -> t tzresult\n\nval remove_staked_frozen : amount:Tez_repr.t -> t -> t tzresult\n\nval add_delegated :\n current_level:Level_repr.t -> amount:Tez_repr.t -> t -> t tzresult\n\nval add_own_frozen : amount:Tez_repr.t -> t -> t tzresult\n\nval add_staked_frozen : amount:Tez_repr.t -> t -> t tzresult\n\nmodule Internal_for_tests_and_RPCs : sig\n val min_delegated_in_cycle : t -> Tez_repr.t\n\n val level_of_min_delegated : t -> Level_repr.t option\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** This module is responsible for the construction, observation and encoding of\n full staking balances that are maintained to be used at cycle end to compute\n staking rights.\n\n The module will handle a lazy migration starting at protocol P that adds two\n new fields to the balance, the minimal delegated balance over the cycle and\n the last level at which it has been modified.\n As there is no trivial default value for Level_repr, the\n level_of_min_delegated is optional but the module must preserve the\n invariant that if a min_delegated_in_cycle has been stored, a level is\n stored with it.\n*)\n\ntype t = {\n own_frozen : Tez_repr.t;\n staked_frozen : Tez_repr.t;\n delegated : Tez_repr.t;\n min_delegated_in_cycle : Tez_repr.t;\n level_of_min_delegated : Level_repr.t option;\n}\n\nlet cycle_of_min_delegated (level_of_min_delegated : Level_repr.t option) =\n match level_of_min_delegated with\n | None -> Cycle_repr.root\n | Some l -> l.cycle\n\nlet init ~own_frozen ~staked_frozen ~delegated ~current_level =\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle = delegated;\n level_of_min_delegated = Some current_level;\n }\n\nlet encoding =\n let open Data_encoding in\n (* This encoding is backward-compatible with the encoding used in Oxford, so\n as to avoid a stitching in P. It will act as a lazy migration.\n The case in which [added_in_p] is [None] happen only for pre-existing\n values in the storage.\n For them, using [(delegated, None)] and using Cycle_repr.root when no level\n is set will behave correctly. *)\n let added_in_p =\n obj2\n (req \"min_delegated_in_cycle\" Tez_repr.encoding)\n (req \"level_of_min_delegated\" (option Level_repr.encoding))\n in\n conv\n (fun {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } ->\n ( own_frozen,\n staked_frozen,\n delegated,\n Some (min_delegated_in_cycle, level_of_min_delegated) ))\n (fun (own_frozen, staked_frozen, delegated, added_in_p_opt) ->\n let min_delegated_in_cycle, level_of_min_delegated =\n added_in_p_opt |> Option.value ~default:(delegated, None)\n in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n })\n (obj4\n (req \"own_frozen\" Tez_repr.encoding)\n (req \"staked_frozen\" Tez_repr.encoding)\n (req \"delegated\" Tez_repr.encoding)\n (varopt \"min_delegated_in_cycle_and_level\" added_in_p))\n\nlet voting_weight\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n let open Result_syntax in\n let* frozen = Tez_repr.(own_frozen +? staked_frozen) in\n let+ all = Tez_repr.(frozen +? delegated) in\n Tez_repr.to_mutez all\n\nlet apply_slashing ~percentage\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let remaining_percentage = Percentage.neg percentage in\n let own_frozen =\n Tez_repr.mul_percentage ~rounding:`Down own_frozen remaining_percentage\n in\n let staked_frozen =\n Tez_repr.mul_percentage ~rounding:`Down staked_frozen remaining_percentage\n in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nlet own_frozen\n {\n own_frozen;\n staked_frozen = _;\n delegated = _;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n own_frozen\n\nlet staked_frozen\n {\n own_frozen = _;\n staked_frozen;\n delegated = _;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n staked_frozen\n\nlet total_frozen\n {\n own_frozen;\n staked_frozen;\n delegated = _;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n Tez_repr.(own_frozen +? staked_frozen)\n\nlet current_delegated\n {\n own_frozen = _;\n staked_frozen = _;\n delegated;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n delegated\n\n(* The minimum over the cycle is either:\n - the current delegated value if it didn't change during the cycle, i.e.\n [cycle_of_min_delegated] is not the current cycle;\n - or the stored [min_delegated_in_cycle] otherwise.\n*)\nlet min_delegated_in_cycle ~current_cycle\n {\n own_frozen = _;\n staked_frozen = _;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let cycle_of_min_delegated = cycle_of_min_delegated level_of_min_delegated in\n if Cycle_repr.(cycle_of_min_delegated < current_cycle) then delegated\n else (\n assert (Cycle_repr.(cycle_of_min_delegated = current_cycle)) ;\n min_delegated_in_cycle)\n\nlet current_total\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n let open Result_syntax in\n let* total_frozen = Tez_repr.(own_frozen +? staked_frozen) in\n Tez_repr.(total_frozen +? delegated)\n\nlet allowed_staked_frozen ~adaptive_issuance_global_limit_of_staking_over_baking\n ~delegate_limit_of_staking_over_baking_millionth\n {\n own_frozen;\n staked_frozen;\n delegated = _;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } =\n let global_limit_of_staking_over_baking_millionth =\n Int64.(\n mul\n 1_000_000L\n (of_int adaptive_issuance_global_limit_of_staking_over_baking))\n in\n let limit_of_staking_over_baking_millionth =\n Compare.Int64.min\n global_limit_of_staking_over_baking_millionth\n (Int64.of_int32 delegate_limit_of_staking_over_baking_millionth)\n in\n match\n Tez_repr.mul_ratio\n ~rounding:`Down\n own_frozen\n ~num:limit_of_staking_over_baking_millionth\n ~den:1_000_000L\n with\n | Ok max_allowed_staked_frozen ->\n Tez_repr.min staked_frozen max_allowed_staked_frozen\n | Error _max_allowed_staked_frozen_overflows -> staked_frozen\n\nlet own_ratio ~adaptive_issuance_global_limit_of_staking_over_baking\n ~delegate_limit_of_staking_over_baking_millionth\n ({\n own_frozen;\n staked_frozen = _;\n delegated = _;\n min_delegated_in_cycle = _;\n level_of_min_delegated = _;\n } as t) =\n if Tez_repr.(own_frozen = zero) then (0L, 1L)\n else\n let allowed_staked_frozen =\n allowed_staked_frozen\n ~adaptive_issuance_global_limit_of_staking_over_baking\n ~delegate_limit_of_staking_over_baking_millionth\n t\n in\n if Tez_repr.(allowed_staked_frozen = zero) then (1L, 1L)\n else\n let own_frozen = Tez_repr.to_mutez own_frozen in\n let allowed_staked_frozen = Tez_repr.to_mutez allowed_staked_frozen in\n (own_frozen, Int64.add own_frozen allowed_staked_frozen)\n\nlet has_minimal_frozen_stake ~minimal_frozen_stake full_staking_balance =\n let own_frozen = own_frozen full_staking_balance in\n Tez_repr.(own_frozen >= minimal_frozen_stake)\n\n(* The set of delegates to consider [Active_delegates_with_minimal_stake] is an\n over-approximation of participating delegates. It is maintained by\n {!Stake_storage}.\n To avoid having to do any maintenance at cycle end, we have to rely on values\n that do not change when crossing cycle boundaries: the current amount works,\n the minimal in a given cycle wouldn't. *)\nlet has_minimal_stake_to_be_considered ~minimal_stake full_staking_balance =\n match current_total full_staking_balance with\n | Error _total_overflows ->\n true\n (* If the total overflows, we are definitely over the minimal stake. *)\n | Ok staking_balance -> Tez_repr.(staking_balance >= minimal_stake)\n\nlet remove_delegated ~(current_level : Level_repr.t) ~amount\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle = old_min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let open Result_syntax in\n let+ delegated = Tez_repr.(delegated -? amount) in\n let cycle_of_min_delegated = cycle_of_min_delegated level_of_min_delegated in\n let current_cycle = current_level.cycle in\n let min_delegated_in_cycle, level_of_min_delegated =\n if Cycle_repr.(cycle_of_min_delegated < current_cycle) then\n (* after decrease *) (delegated, Some current_level)\n else (\n assert (Cycle_repr.(cycle_of_min_delegated = current_cycle)) ;\n let minimum = Tez_repr.min delegated old_min_delegated_in_cycle in\n ( minimum,\n if Tez_repr.(minimum = old_min_delegated_in_cycle) then\n level_of_min_delegated\n else Some current_level ))\n in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nlet remove_own_frozen ~amount\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let open Result_syntax in\n let+ own_frozen = Tez_repr.(own_frozen -? amount) in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nlet remove_staked_frozen ~amount\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let open Result_syntax in\n let+ staked_frozen = Tez_repr.(staked_frozen -? amount) in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nlet add_delegated ~(current_level : Level_repr.t) ~amount\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle = old_min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let open Result_syntax in\n let cycle_of_min_delegated = cycle_of_min_delegated level_of_min_delegated in\n let current_cycle = current_level.cycle in\n let min_delegated_in_cycle, level_of_min_delegated =\n if Cycle_repr.(cycle_of_min_delegated < current_cycle) then\n (* before increase *) (delegated, Some current_level)\n else (\n assert (Cycle_repr.(cycle_of_min_delegated = current_cycle)) ;\n (old_min_delegated_in_cycle, level_of_min_delegated))\n in\n let+ delegated = Tez_repr.(delegated +? amount) in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nlet add_own_frozen ~amount\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let open Result_syntax in\n let+ own_frozen = Tez_repr.(own_frozen +? amount) in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nlet add_staked_frozen ~amount\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n } =\n let open Result_syntax in\n let+ staked_frozen = Tez_repr.(staked_frozen +? amount) in\n {\n own_frozen;\n staked_frozen;\n delegated;\n min_delegated_in_cycle;\n level_of_min_delegated;\n }\n\nmodule Internal_for_tests_and_RPCs = struct\n let min_delegated_in_cycle\n {\n own_frozen = _;\n staked_frozen = _;\n delegated = _;\n min_delegated_in_cycle;\n level_of_min_delegated = _;\n } =\n min_delegated_in_cycle\n\n let level_of_min_delegated\n {\n own_frozen = _;\n staked_frozen = _;\n delegated = _;\n min_delegated_in_cycle = _;\n level_of_min_delegated;\n } =\n level_of_min_delegated\nend\n" ;
} ;
{ name = "Unstaked_frozen_staker_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** Adding and removing unstaked frozen stake can be done from/toward a\n delegate, one of its staker, or both the delegate and all its stakers at\n once. We need to distinguish these cases to enforce the staking\n over baking limit. *)\ntype t =\n | Single of Contract_repr.t * Signature.public_key_hash\n (** A single staker, either the delegate itself or one of its staker. *)\n | Shared of Signature.public_key_hash\n (** The delegate and all its stakers simultaneously. *)\n\nval encoding : t Data_encoding.t\n\nval compare : t -> t -> int\n\nval delegate : t -> Signature.public_key_hash\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype t =\n | Single of Contract_repr.t * Signature.public_key_hash\n | Shared of Signature.public_key_hash\n\nlet encoding =\n let open Data_encoding in\n let single_tag = 0 in\n let single_encoding =\n obj2\n (req \"contract\" Contract_repr.encoding)\n (req \"delegate\" Signature.Public_key_hash.encoding)\n in\n let shared_tag = 1 in\n let shared_encoding =\n obj1 (req \"delegate\" Signature.Public_key_hash.encoding)\n in\n def\n ~title:\"unstaked_frozen_staker\"\n ~description:\n \"Abstract notion of staker used in operation receipts for unstaked \\\n frozen deposits, either a single staker or all the stakers delegating \\\n to some delegate.\"\n \"staker\"\n @@ matching\n (function\n | Single (contract, delegate) ->\n matched single_tag single_encoding (contract, delegate)\n | Shared delegate -> matched shared_tag shared_encoding delegate)\n [\n case\n ~title:\"Single\"\n (Tag single_tag)\n single_encoding\n (function\n | Single (contract, delegate) -> Some (contract, delegate)\n | _ -> None)\n (fun (contract, delegate) -> Single (contract, delegate));\n case\n ~title:\"Shared\"\n (Tag shared_tag)\n shared_encoding\n (function Shared delegate -> Some delegate | _ -> None)\n (fun delegate -> Shared delegate);\n ]\n\nlet compare sa sb =\n match (sa, sb) with\n | Single (ca, da), Single (cb, db) ->\n Compare.or_else (Contract_repr.compare ca cb) (fun () ->\n Signature.Public_key_hash.compare da db)\n | Shared da, Shared db -> Signature.Public_key_hash.compare da db\n | Single _, Shared _ -> -1\n | Shared _, Single _ -> 1\n\nlet delegate = function\n | Single (_contract, delegate) -> delegate\n | Shared delegate -> delegate\n" ;
} ;
{ name = "Frozen_staker_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** Adding and removing stake can be done from/toward the funds\n - a delegate directly stakes,\n - one of its stakers stakes,\n - all its stakers stakes at once,\n - or from the edge a delegate may have on its stakers rewards.\n We need to distinguish these cases to enforce the staking over baking\n limit. *)\ntype t = private\n | Baker of Signature.public_key_hash (** The baker itself. *)\n | Single_staker of {\n staker : Contract_repr.t;\n delegate : Signature.public_key_hash;\n } (** A single staker, cannot be the delegate. *)\n | Shared_between_stakers of {delegate : Signature.public_key_hash}\n (** The delegate's stakers simultaneously (delegate excluded). *)\n | Baker_edge of Signature.public_key_hash\n (** The baker edge over its stakers rewards. *)\n\nval baker : Signature.public_key_hash -> t\n\nval baker_edge : Signature.public_key_hash -> t\n\nval single_staker :\n staker:Contract_repr.t -> delegate:Signature.public_key_hash -> t\n\nval shared_between_stakers : delegate:Signature.public_key_hash -> t\n\nval encoding : t Data_encoding.t\n\nval compare : t -> t -> int\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype t =\n | Baker of Signature.public_key_hash\n | Single_staker of {\n staker : Contract_repr.t;\n delegate : Signature.public_key_hash;\n }\n | Shared_between_stakers of {delegate : Signature.public_key_hash}\n | Baker_edge of Signature.public_key_hash\n\nlet baker pkh = Baker pkh\n\nlet baker_edge pkh = Baker_edge pkh\n\nlet single_staker ~staker ~delegate =\n match (staker : Contract_repr.t) with\n | Implicit pkh when Signature.Public_key_hash.(pkh = delegate) -> Baker pkh\n | _ -> Single_staker {staker; delegate}\n\nlet shared_between_stakers ~delegate = Shared_between_stakers {delegate}\n\nlet encoding =\n let open Data_encoding in\n let single_tag = 0 in\n let single_encoding =\n obj2\n (req \"contract\" Contract_repr.encoding)\n (req \"delegate\" Signature.Public_key_hash.encoding)\n in\n let shared_tag = 1 in\n let shared_encoding =\n obj1 (req \"delegate\" Signature.Public_key_hash.encoding)\n in\n let baker_tag = 2 in\n let baker_encoding =\n obj1 (req \"baker_own_stake\" Signature.Public_key_hash.encoding)\n in\n let baker_edge_tag = 3 in\n let baker_edge_encoding =\n obj1 (req \"baker_edge\" Signature.Public_key_hash.encoding)\n in\n def\n ~title:\"frozen_staker\"\n ~description:\n \"Abstract notion of staker used in operation receipts for frozen \\\n deposits, either a single staker or all the stakers delegating to some \\\n delegate.\"\n \"frozen_staker\"\n @@ matching\n (function\n | Baker baker -> matched baker_tag baker_encoding baker\n | Single_staker {staker; delegate} ->\n matched single_tag single_encoding (staker, delegate)\n | Shared_between_stakers {delegate} ->\n matched shared_tag shared_encoding delegate\n | Baker_edge baker -> matched baker_edge_tag baker_edge_encoding baker)\n [\n case\n ~title:\"Single\"\n (Tag single_tag)\n single_encoding\n (function\n | Single_staker {staker; delegate} -> Some (staker, delegate)\n | _ -> None)\n (fun (staker, delegate) -> single_staker ~staker ~delegate);\n case\n ~title:\"Shared\"\n (Tag shared_tag)\n shared_encoding\n (function\n | Shared_between_stakers {delegate} -> Some delegate | _ -> None)\n (fun delegate -> Shared_between_stakers {delegate});\n case\n ~title:\"Baker\"\n (Tag baker_tag)\n baker_encoding\n (function Baker baker -> Some baker | _ -> None)\n (fun baker -> Baker baker);\n case\n ~title:\"Baker_edge\"\n (Tag baker_edge_tag)\n baker_edge_encoding\n (function Baker_edge baker -> Some baker | _ -> None)\n (fun baker -> Baker_edge baker);\n ]\n\nlet compare sa sb =\n match (sa, sb) with\n | Baker ba, Baker bb -> Signature.Public_key_hash.compare ba bb\n | Baker _, _ -> -1\n | _, Baker _ -> 1\n | ( Single_staker {staker = sa; delegate = da},\n Single_staker {staker = sb; delegate = db} ) ->\n Compare.or_else (Contract_repr.compare sa sb) (fun () ->\n Signature.Public_key_hash.compare da db)\n | ( Shared_between_stakers {delegate = da},\n Shared_between_stakers {delegate = db} ) ->\n Signature.Public_key_hash.compare da db\n | Single_staker _, Shared_between_stakers _ -> -1\n | Shared_between_stakers _, Single_staker _ -> 1\n | Baker_edge ba, Baker_edge bb -> Signature.Public_key_hash.compare ba bb\n | Baker_edge _, _ -> -1\n | _, Baker_edge _ -> 1\n" ;
} ;
{ name = "Stake_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(** Stake of a delegate.\n\n It has the invariants enforced by {!Stake_context.apply_limits}:\n [frozen] excludes any overstaked tez, and [weighted_delegated]\n includes overstaked tez but excludes overdelegated tez. *)\ntype t = private {frozen : Tez_repr.t; weighted_delegated : Tez_repr.t}\n\nval zero : t\n\n(** Builds a {!t}. Should only be called in\n {!Stake_context.apply_limits} to enforce the invariants. *)\nval make : frozen:Tez_repr.t -> weighted_delegated:Tez_repr.t -> t\n\nval encoding : t Data_encoding.t\n\n(** Returns only the frozen part of a stake. This includes the frozen\n balances from the delegate and any stakers, but excludes any\n overstaked tez. *)\nval get_frozen : t -> Tez_repr.t\n\nval ( +? ) : t -> t -> t tzresult\n\n(** The weight of a staker or a set of stakers. Since this\n function is applied on a [Stake_repr.t], the limits should already\n have been applied using [apply_limits] if necessary. *)\nval staking_weight : t -> int64\n\nval compare : t -> t -> int\n\nval has_minimal_stake_to_participate : minimal_stake:Tez_repr.t -> t -> bool\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 = {frozen : Tez_repr.t; weighted_delegated : Tez_repr.t}\n\nlet make ~frozen ~weighted_delegated = {frozen; weighted_delegated}\n\nlet get_frozen {frozen; _} = frozen\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {frozen; weighted_delegated} -> (frozen, weighted_delegated))\n (fun (frozen, weighted_delegated) -> {frozen; weighted_delegated})\n (obj2 (req \"frozen\" Tez_repr.encoding) (req \"delegated\" Tez_repr.encoding))\n\nlet zero = make ~frozen:Tez_repr.zero ~weighted_delegated:Tez_repr.zero\n\nlet ( +? ) {frozen = f1; weighted_delegated = d1}\n {frozen = f2; weighted_delegated = d2} =\n let open Result_syntax in\n let* frozen = Tez_repr.(f1 +? f2) in\n let+ weighted_delegated = Tez_repr.(d1 +? d2) in\n {frozen; weighted_delegated}\n\nlet staking_weight {frozen; weighted_delegated} =\n let frozen = Tez_repr.to_mutez frozen in\n let weighted_delegated = Tez_repr.to_mutez weighted_delegated in\n Int64.add frozen weighted_delegated\n\nlet compare s1 s2 = Int64.compare (staking_weight s1) (staking_weight s2)\n\nlet has_minimal_stake_to_participate ~minimal_stake {frozen; weighted_delegated}\n =\n match Tez_repr.(frozen +? weighted_delegated) with\n | Error _total_overflows -> true\n | Ok total -> Tez_repr.(total >= minimal_stake)\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\nmodule Token : sig\n type 'token t =\n | Tez : Tez_repr.t t\n | Staking_pseudotoken : Staking_pseudotoken_repr.t t\n\n val eq :\n 'token1 t -> 'token2 t -> ('token1, 'token2) Equality_witness.eq option\n\n val equal : 'token t -> 'token -> 'token -> bool\n\n val is_zero : 'token t -> 'token -> bool\n\n val add : 'token t -> 'token -> 'token -> 'token tzresult\n\n val pp : 'token t -> Format.formatter -> 'token -> unit\nend\n\n(** Places where tokens can be found in the ledger's state. *)\ntype 'token balance =\n | Contract : Contract_repr.t -> Tez_repr.t balance\n | Block_fees : Tez_repr.t balance\n | Deposits : Frozen_staker_repr.t -> Tez_repr.t balance\n | Unstaked_deposits :\n Unstaked_frozen_staker_repr.t * Cycle_repr.t\n -> Tez_repr.t balance\n | Nonce_revelation_rewards : Tez_repr.t balance\n | Attesting_rewards : Tez_repr.t balance\n | Baking_rewards : Tez_repr.t balance\n | Baking_bonuses : Tez_repr.t balance\n | Storage_fees : Tez_repr.t balance\n | Double_signing_punishments : Tez_repr.t balance\n | Lost_attesting_rewards :\n Signature.Public_key_hash.t * bool * bool\n -> Tez_repr.t balance\n | Liquidity_baking_subsidies : Tez_repr.t balance\n | Burned : Tez_repr.t balance\n | Commitments : Blinded_public_key_hash.t -> Tez_repr.t balance\n | Bootstrap : Tez_repr.t balance\n | Invoice : Tez_repr.t balance\n | Initial_commitments : Tez_repr.t balance\n | Minted : Tez_repr.t balance\n | Frozen_bonds : Contract_repr.t * Bond_id_repr.t -> Tez_repr.t balance\n | Sc_rollup_refutation_punishments : Tez_repr.t balance\n | Sc_rollup_refutation_rewards : Tez_repr.t balance\n | Staking_delegator_numerator : {\n delegator : Contract_repr.t;\n }\n -> Staking_pseudotoken_repr.t balance\n | Staking_delegate_denominator : {\n delegate : Signature.public_key_hash;\n }\n -> Staking_pseudotoken_repr.t balance\n\nval token_of_balance : 'token balance -> 'token Token.t\n\n(** Compares two balances. *)\nval compare_balance : 'token1 balance -> 'token2 balance -> int\n\n(** A credit or debit of token to a balance. *)\ntype 'token balance_update = Debited of 'token | Credited of 'token\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 | Delayed_operation of {operation_hash : Operation_hash.t}\n (** Delayed application of an operation, whose hash is given. E.g. for\n operations that take effect only at the end of the cycle. *)\n\n(** Compares two origins. *)\nval compare_update_origin : update_origin -> update_origin -> int\n\n(** An item in a list of balance updates. \n An item of the form [(Rewards (b,c), Credited am, ...)] indicates that the\n balance of frozen rewards has been increased by [am] for baker [b] and cycle\n [c]. *)\ntype balance_update_item = private\n | Balance_update_item :\n 'token balance * 'token balance_update * update_origin\n -> balance_update_item\n\n(** Smart constructor for [balance_update_item]. *)\nval item :\n 'token balance ->\n 'token balance_update ->\n update_origin ->\n balance_update_item\n\n(** A list of balance updates. Duplicates may happen. *)\ntype balance_updates = balance_update_item 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(** Balance updates encoding that uses legacy attestation name : `endorsing\n right` and `lost endorsing right` when encoding to JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5529\n\n This encoding is temporary and should be removed when the endorsements kinds\n in JSON will not be accepted any more by the protocol.\n*)\nval balance_updates_encoding_with_legacy_attestation_name :\n 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\nmodule Token = struct\n type 'token t =\n | Tez : Tez_repr.t t\n | Staking_pseudotoken : Staking_pseudotoken_repr.t t\n\n let eq :\n type token1 token2.\n token1 t -> token2 t -> (token1, token2) Equality_witness.eq option =\n fun t1 t2 ->\n match (t1, t2) with\n | Tez, Tez -> Some Refl\n | Tez, _ | _, Tez -> None\n | Staking_pseudotoken, Staking_pseudotoken -> Some Refl\n\n let equal : type token. token t -> token -> token -> bool = function\n | Tez -> Tez_repr.( = )\n | Staking_pseudotoken -> Staking_pseudotoken_repr.( = )\n\n let is_zero : type token. token t -> token -> bool =\n fun token t ->\n match token with\n | Tez -> Tez_repr.(t = zero)\n | Staking_pseudotoken -> Staking_pseudotoken_repr.(t = zero)\n\n let le : type token. token t -> token -> token -> bool = function\n | Tez -> Tez_repr.( <= )\n | Staking_pseudotoken -> Staking_pseudotoken_repr.( <= )\n\n let add : type token. token t -> token -> token -> token tzresult = function\n | Tez -> Tez_repr.( +? )\n | Staking_pseudotoken -> Staking_pseudotoken_repr.( +? )\n\n let sub : type token. token t -> token -> token -> token tzresult = function\n | Tez -> Tez_repr.( -? )\n | Staking_pseudotoken -> Staking_pseudotoken_repr.( -? )\n\n let pp_tez =\n let tez_sym = \"\\xEA\\x9C\\xA9\" in\n fun ppf tez -> Format.fprintf ppf \"%s%a\" tez_sym Tez_repr.pp tez\n\n let pp : type token. token t -> Format.formatter -> token -> unit = function\n | Tez -> pp_tez\n | Staking_pseudotoken -> Staking_pseudotoken_repr.pp\nend\n\ntype 'token balance =\n | Contract : Contract_repr.t -> Tez_repr.t balance\n | Block_fees : Tez_repr.t balance\n | Deposits : Frozen_staker_repr.t -> Tez_repr.t balance\n | Unstaked_deposits :\n Unstaked_frozen_staker_repr.t * Cycle_repr.t\n -> Tez_repr.t balance\n | Nonce_revelation_rewards : Tez_repr.t balance\n | Attesting_rewards : Tez_repr.t balance\n | Baking_rewards : Tez_repr.t balance\n | Baking_bonuses : Tez_repr.t balance\n | Storage_fees : Tez_repr.t balance\n | Double_signing_punishments : Tez_repr.t balance\n | Lost_attesting_rewards :\n Signature.Public_key_hash.t * bool * bool\n -> Tez_repr.t balance\n | Liquidity_baking_subsidies : Tez_repr.t balance\n | Burned : Tez_repr.t balance\n | Commitments : Blinded_public_key_hash.t -> Tez_repr.t balance\n | Bootstrap : Tez_repr.t balance\n | Invoice : Tez_repr.t balance\n | Initial_commitments : Tez_repr.t balance\n | Minted : Tez_repr.t balance\n | Frozen_bonds : Contract_repr.t * Bond_id_repr.t -> Tez_repr.t balance\n | Sc_rollup_refutation_punishments : Tez_repr.t balance\n | Sc_rollup_refutation_rewards : Tez_repr.t balance\n | Staking_delegator_numerator : {\n delegator : Contract_repr.t;\n }\n -> Staking_pseudotoken_repr.t balance\n | Staking_delegate_denominator : {\n delegate : Signature.public_key_hash;\n }\n -> Staking_pseudotoken_repr.t balance\n\nlet token_of_balance : type token. token balance -> token Token.t = function\n | Contract _ -> Token.Tez\n | Block_fees -> Token.Tez\n | Deposits _ -> Token.Tez\n | Unstaked_deposits _ -> Token.Tez\n | Nonce_revelation_rewards -> Token.Tez\n | Attesting_rewards -> Token.Tez\n | Baking_rewards -> Token.Tez\n | Baking_bonuses -> Token.Tez\n | Storage_fees -> Token.Tez\n | Double_signing_punishments -> Token.Tez\n | Lost_attesting_rewards _ -> Token.Tez\n | Liquidity_baking_subsidies -> Token.Tez\n | Burned -> Token.Tez\n | Commitments _ -> Token.Tez\n | Bootstrap -> Token.Tez\n | Invoice -> Token.Tez\n | Initial_commitments -> Token.Tez\n | Minted -> Token.Tez\n | Frozen_bonds _ -> Token.Tez\n | Sc_rollup_refutation_punishments -> Token.Tez\n | Sc_rollup_refutation_rewards -> Token.Tez\n | Staking_delegator_numerator _ -> Token.Staking_pseudotoken\n | Staking_delegate_denominator _ -> Token.Staking_pseudotoken\n\nlet is_not_zero c = not (Compare.Int.equal c 0)\n\nlet compare_balance :\n type token1 token2. token1 balance -> token2 balance -> int =\n fun ba bb ->\n match (ba, bb) with\n | Contract ca, Contract cb -> Contract_repr.compare ca cb\n | Deposits sa, Deposits sb -> Frozen_staker_repr.compare sa sb\n | Unstaked_deposits (sa, ca), Unstaked_deposits (sb, cb) ->\n Compare.or_else (Unstaked_frozen_staker_repr.compare sa sb) (fun () ->\n Cycle_repr.compare ca cb)\n | Lost_attesting_rewards (pkha, pa, ra), Lost_attesting_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 | ( Staking_delegator_numerator {delegator = ca},\n Staking_delegator_numerator {delegator = cb} ) ->\n Contract_repr.compare ca cb\n | ( Staking_delegate_denominator {delegate = pkha},\n Staking_delegate_denominator {delegate = pkhb} ) ->\n Signature.Public_key_hash.compare pkha pkhb\n | _, _ ->\n let index : type token. token balance -> int = function\n | Contract _ -> 0\n | Block_fees -> 1\n | Deposits _ -> 2\n | Unstaked_deposits _ -> 3\n | Nonce_revelation_rewards -> 4\n | Attesting_rewards -> 5\n | Baking_rewards -> 6\n | Baking_bonuses -> 7\n | Storage_fees -> 8\n | Double_signing_punishments -> 9\n | Lost_attesting_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 | Sc_rollup_refutation_punishments -> 19\n | Sc_rollup_refutation_rewards -> 20\n | Staking_delegator_numerator _ -> 21\n | Staking_delegate_denominator _ -> 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 'token balance_update = Debited of 'token | Credited of 'token\n\ntype balance_and_update =\n | Ex_token : 'token balance * 'token balance_update -> balance_and_update\n\nlet is_zero_update : type token. token Token.t -> token balance_update -> bool =\n fun token -> function Debited t | Credited t -> Token.is_zero token t\n\nlet conv_balance_update encoding =\n Data_encoding.conv\n (function Credited v -> `Credited v | Debited v -> `Debited v)\n (function `Credited v -> Credited v | `Debited v -> Debited v)\n encoding\n\nlet tez_balance_update_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.tez_balance_update\"\n @@ obj1 (req \"change\" (conv_balance_update Tez_repr.balance_update_encoding))\n\nlet staking_pseudotoken_balance_update_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.staking_abstract_quantity\"\n @@ obj1\n (req\n \"change\"\n (conv_balance_update Staking_pseudotoken_repr.balance_update_encoding))\n\nlet balance_and_update_encoding ~use_legacy_attestation_name =\n let open Data_encoding in\n let case = function\n | Tag tag ->\n (* The tag was used by old variant. It have been removed in\n protocol proposal O, it can be unblocked in the future. *)\n let tx_rollup_reserved_tag = [22; 23] in\n assert (\n not @@ List.exists (Compare.Int.equal tag) tx_rollup_reserved_tag) ;\n case (Tag tag)\n | _ as c -> case c\n in\n let tez_case ~title tag enc (proj : Tez_repr.t balance -> _ option) inj =\n case\n ~title\n tag\n (merge_objs enc tez_balance_update_encoding)\n (fun (Ex_token (balance, update)) ->\n match token_of_balance balance with\n | Tez -> proj balance |> Option.map (fun x -> (x, update))\n | _ -> None)\n (fun (x, update) -> Ex_token (inj x, update))\n in\n let staking_pseudotoken_case ~title tag enc\n (proj : Staking_pseudotoken_repr.t balance -> _ option) inj =\n case\n ~title\n tag\n (merge_objs enc staking_pseudotoken_balance_update_encoding)\n (fun (Ex_token (balance, update)) ->\n match token_of_balance balance with\n | Staking_pseudotoken ->\n proj balance |> Option.map (fun x -> (x, update))\n | _ -> None)\n (fun (x, update) -> Ex_token (inj x, update))\n in\n def\n (if use_legacy_attestation_name then\n \"operation_metadata_with_legacy_attestation_name.alpha.balance_and_update\"\n else \"operation_metadata.alpha.balance_and_update\")\n @@ union\n [\n tez_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 tez_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 tez_case\n (Tag 4)\n ~title:\"Deposits\"\n (obj3\n (req \"kind\" (constant \"freezer\"))\n (req \"category\" (constant \"deposits\"))\n (req \"staker\" Frozen_staker_repr.encoding))\n (function Deposits staker -> Some ((), (), staker) | _ -> None)\n (fun ((), (), staker) -> Deposits staker);\n tez_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 (* 6 was for Double_signing_evidence_rewards that has been removed.\n https://gitlab.com/tezos/tezos/-/merge_requests/7758 *)\n tez_case\n (Tag 7)\n ~title:\n (if use_legacy_attestation_name then \"Endorsing_rewards\"\n else \"Attesting_rewards\")\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req\n \"category\"\n (constant\n (if use_legacy_attestation_name then \"endorsing rewards\"\n else \"attesting rewards\"))))\n (function Attesting_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Attesting_rewards);\n tez_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 tez_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 tez_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 tez_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 tez_case\n (Tag 13)\n ~title:\n (if use_legacy_attestation_name then \"Lost_endorsing_rewards\"\n else \"Lost_attesting_rewards\")\n (obj5\n (req \"kind\" (constant \"burned\"))\n (req\n \"category\"\n (constant\n (if use_legacy_attestation_name then\n \"lost endorsing rewards\"\n else \"lost attesting 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_attesting_rewards (d, p, r) -> Some ((), (), d, p, r)\n | _ -> None)\n (fun ((), (), d, p, r) -> Lost_attesting_rewards (d, p, r));\n tez_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 tez_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 tez_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 tez_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 tez_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 tez_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 tez_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 tez_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 tez_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 tez_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 tez_case\n (Tag 26)\n ~title:\"Unstaked_deposits\"\n (obj4\n (req \"kind\" (constant \"freezer\"))\n (req \"category\" (constant \"unstaked_deposits\"))\n (req \"staker\" Unstaked_frozen_staker_repr.encoding)\n (req \"cycle\" Cycle_repr.encoding))\n (function\n | Unstaked_deposits (staker, cycle) -> Some ((), (), staker, cycle)\n | _ -> None)\n (fun ((), (), staker, cycle) -> Unstaked_deposits (staker, cycle));\n staking_pseudotoken_case\n (Tag 27)\n ~title:\"Staking_delegator_numerator\"\n (obj3\n (req \"kind\" (constant \"staking\"))\n (req \"category\" (constant \"delegator_numerator\"))\n (req \"delegator\" Contract_repr.encoding))\n (function\n | Staking_delegator_numerator {delegator} ->\n Some ((), (), delegator)\n | _ -> None)\n (fun ((), (), delegator) -> Staking_delegator_numerator {delegator});\n staking_pseudotoken_case\n (Tag 28)\n ~title:\"Staking_delegate_denominator\"\n (obj3\n (req \"kind\" (constant \"staking\"))\n (req \"category\" (constant \"delegate_denominator\"))\n (req \"delegate\" Signature.Public_key_hash.encoding))\n (function\n | Staking_delegate_denominator {delegate} -> Some ((), (), delegate)\n | _ -> None)\n (fun ((), (), delegate) -> Staking_delegate_denominator {delegate});\n ]\n\nlet balance_and_update_encoding_with_legacy_attestation_name =\n balance_and_update_encoding ~use_legacy_attestation_name:true\n\nlet balance_and_update_encoding =\n balance_and_update_encoding ~use_legacy_attestation_name:false\n\ntype update_origin =\n | Block_application\n | Protocol_migration\n | Subsidy\n | Simulation\n | Delayed_operation of {operation_hash : Operation_hash.t}\n\nlet compare_update_origin oa ob =\n match (oa, ob) with\n | ( Delayed_operation {operation_hash = oha},\n Delayed_operation {operation_hash = ohb} ) ->\n Operation_hash.compare oha ohb\n | _, _ ->\n let index o =\n match o with\n | Block_application -> 0\n | Protocol_migration -> 1\n | Subsidy -> 2\n | Simulation -> 3\n | Delayed_operation _ -> 4\n (* don't forget to add parameterized cases in the first part of the function *)\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 @@ union\n [\n case\n (Tag 0)\n ~title:\"Block_application\"\n (obj1 (req \"origin\" (constant \"block\")))\n (function Block_application -> Some () | _ -> None)\n (fun () -> Block_application);\n case\n (Tag 1)\n ~title:\"Protocol_migration\"\n (obj1 (req \"origin\" (constant \"migration\")))\n (function Protocol_migration -> Some () | _ -> None)\n (fun () -> Protocol_migration);\n case\n (Tag 2)\n ~title:\"Subsidy\"\n (obj1 (req \"origin\" (constant \"subsidy\")))\n (function Subsidy -> Some () | _ -> None)\n (fun () -> Subsidy);\n case\n (Tag 3)\n ~title:\"Simulation\"\n (obj1 (req \"origin\" (constant \"simulation\")))\n (function Simulation -> Some () | _ -> None)\n (fun () -> Simulation);\n case\n (Tag 4)\n ~title:\"Delayed_operation\"\n (obj2\n (req \"origin\" (constant \"delayed_operation\"))\n (req \"delayed_operation_hash\" Operation_hash.encoding))\n (function\n | Delayed_operation {operation_hash} -> Some ((), operation_hash)\n | _ -> None)\n (fun ((), operation_hash) -> Delayed_operation {operation_hash});\n ]\n\ntype balance_update_item =\n | Balance_update_item :\n 'token balance * 'token balance_update * update_origin\n -> balance_update_item\n\nlet item balance balance_update update_origin =\n Balance_update_item (balance, balance_update, update_origin)\n\nlet item_encoding_with_legacy_attestation_name =\n let open Data_encoding in\n conv\n (function\n | Balance_update_item (balance, balance_update, update_origin) ->\n (Ex_token (balance, balance_update), update_origin))\n (fun (Ex_token (balance, balance_update), update_origin) ->\n Balance_update_item (balance, balance_update, update_origin))\n (merge_objs\n balance_and_update_encoding_with_legacy_attestation_name\n update_origin_encoding)\n\nlet item_encoding =\n let open Data_encoding in\n conv\n (function\n | Balance_update_item (balance, balance_update, update_origin) ->\n (Ex_token (balance, balance_update), update_origin))\n (fun (Ex_token (balance, balance_update), update_origin) ->\n Balance_update_item (balance, balance_update, update_origin))\n (merge_objs balance_and_update_encoding update_origin_encoding)\n\ntype balance_updates = balance_update_item list\n\nlet balance_updates_encoding_with_legacy_attestation_name =\n let open Data_encoding in\n def \"operation_metadata_with_legacy_attestation_name.alpha.balance_updates\"\n @@ list item_encoding_with_legacy_attestation_name\n\nlet balance_updates_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.balance_updates\" @@ list item_encoding\n\nmodule MakeBalanceMap (T : sig\n type token\nend) =\nstruct\n include Map.Make (struct\n type t = T.token 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 let open Result_syntax in\n let* v_opt = f (find key map) in\n match v_opt with\n | Some v -> return (add key v map)\n | None -> return (remove key map)\nend\n\nmodule TezBalanceMap = MakeBalanceMap (struct\n type token = Tez_repr.t\nend)\n\nmodule StakingPseudotokenMap = MakeBalanceMap (struct\n type token = Staking_pseudotoken_repr.t\nend)\n\ntype 'a balance_maps = {\n tez : Tez_repr.t balance_update TezBalanceMap.t;\n staking_pt : Staking_pseudotoken_repr.t balance_update StakingPseudotokenMap.t;\n}\n\nlet group_balance_updates balance_updates =\n let open Result_syntax in\n let update_map token update_r key update map =\n update_r\n key\n (function\n | None -> return_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 Token.equal token a b then return_none\n else if Token.le token b a then\n let* update = Token.sub token a b in\n return_some (Credited update)\n else\n let* update = Token.sub token b a in\n return_some (Debited update)\n | Credited a, Credited b ->\n let* update = Token.add token a b in\n return_some (Credited update)\n | Debited a, Debited b ->\n let* update = Token.add token a b in\n return_some (Debited update)))\n map\n in\n let* {tez; staking_pt} =\n List.fold_left_e\n (fun acc (Balance_update_item (b, update, o)) ->\n (* Do not do anything if the update is zero *)\n let token = token_of_balance b in\n if is_zero_update token update then return acc\n else\n match token with\n | Tez ->\n let+ tez =\n update_map token TezBalanceMap.update_r (b, o) update acc.tez\n in\n {acc with tez}\n | Staking_pseudotoken ->\n let+ staking_pt =\n update_map\n token\n StakingPseudotokenMap.update_r\n (b, o)\n update\n acc.staking_pt\n in\n {acc with staking_pt})\n {tez = TezBalanceMap.empty; staking_pt = StakingPseudotokenMap.empty}\n balance_updates\n in\n return\n (StakingPseudotokenMap.fold\n (fun (b, o) u acc -> Balance_update_item (b, u, o) :: acc)\n staking_pt\n (TezBalanceMap.fold\n (fun (b, o) u acc -> Balance_update_item (b, u, o) :: acc)\n tez\n []))\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_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model carbonated_map/compare_int *)\n(* max 10 2.18333333333 *)\nlet cost_compare_int = S.safe_int 10\n\n(* model carbonated_map/find *)\n(* fun size ->\n max 10 ((50. + ((log2 size) * 2.18333333333)) + ((log2 size) * 2.)) *)\nlet cost_find size =\n let size = S.safe_int size in\n let w1 = log2 size in\n (w1 * S.safe_int 4) + (w1 lsr 3) + (w1 lsr 4) + S.safe_int 50\n\n(* model carbonated_map/find_intercept *)\n(* max 10 50. *)\nlet cost_find_intercept = S.safe_int 50\n\n(* model carbonated_map/fold *)\n(* fun size -> max 10 (50. + (24. * size)) *)\nlet cost_fold size =\n let size = S.safe_int size in\n (size * S.safe_int 24) + S.safe_int 50\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(* Copyright (c) 2023 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 Carbonated_map_costs_generated\nopen S.Syntax\n\ntype cost = Saturation_repr.may_saturate Saturation_repr.t\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 (* intercept: carbonated_map/find/intercept *)\n let intercept = cost_find_intercept in\n let size = S.safe_int size in\n let compare_cost = log2 size * compare_key_cost in\n (* traversal_overhead: carbonated_map/find/traversal_overhead *)\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 = cost_fold 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 let open Result_syntax in\n let+ ctxt = G.consume ctxt (find_cost ~key ~size) in\n (M.find key map, ctxt)\n\n let update ctxt key f {map; size} =\n let open Result_syntax in\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 let* ctxt = G.consume ctxt find_cost in\n let old_val_opt = M.find key map in\n (* The call to [f] must also account for gas *)\n let* new_val_opt, ctxt = f ctxt old_val_opt in\n match (old_val_opt, new_val_opt) with\n | Some _, Some new_val ->\n (* Consume gas for adding to the map *)\n let+ ctxt = G.consume ctxt update_cost in\n ({map = M.add key new_val map; size}, ctxt)\n | Some _, None ->\n (* Consume gas for removing from the map *)\n let+ ctxt = G.consume ctxt update_cost in\n ({map = M.remove key map; size = size - 1}, ctxt)\n | None, Some new_val ->\n (* Consume gas for adding to the map *)\n let+ ctxt = G.consume ctxt update_cost in\n ({map = M.add key new_val map; size = size + 1}, ctxt)\n | None, None -> return ({map; size}, ctxt)\n\n let to_list ctxt {map; size} =\n let open Result_syntax in\n let+ ctxt = G.consume ctxt (Carbonated_map_costs.fold_cost ~size) in\n (M.bindings map, ctxt)\n\n let add ctxt ~merge_overlap key value {map; size} =\n let open Result_syntax in\n (* Consume gas for looking up the element *)\n let* ctxt = G.consume ctxt (find_cost ~key ~size) in\n (* Consume gas for adding the element *)\n let* ctxt = G.consume ctxt (update_cost ~key ~size) in\n match M.find key map with\n | Some old_val ->\n (* Invoking [merge_overlap] must also account for gas *)\n let+ new_value, ctxt = merge_overlap ctxt old_val value in\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 let open Result_syntax in\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 let* ctxt = G.consume ctxt (Carbonated_map_costs.fold_cost ~size) in\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 let open Result_syntax in\n let* ctxt = G.consume ctxt (Carbonated_map_costs.fold_cost ~size) in\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 let open Lwt_result_syntax in\n let*? ctxt = G.consume ctxt (Carbonated_map_costs.fold_cost ~size) in\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 let open Result_syntax in\n (* We cannot use the standard map function because [f] also meters the gas\n cost at each invocation. *)\n let+ map, ctxt =\n fold_e\n ctxt\n (fun ctxt map key value ->\n (* Invoking [f] must also account for gas. *)\n let* value, ctxt = f ctxt key value in\n (* Consume gas for adding the element. *)\n let+ ctxt = G.consume ctxt (update_cost ~key ~size) in\n (M.add key value map, ctxt))\n M.empty\n {map; size}\n in\n ({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 = "Staking_parameters_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 {\n limit_of_staking_over_baking_millionth : int32;\n edge_of_baking_over_staking_billionth : int32;\n}\n\n(** Value used when unset *)\nval default : t\n\ntype error += Invalid_staking_parameters\n\nval make :\n limit_of_staking_over_baking_millionth:Z.t ->\n edge_of_baking_over_staking_billionth:Z.t ->\n t tzresult\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 limit_of_staking_over_baking_millionth : int32;\n edge_of_baking_over_staking_billionth : int32;\n}\n\nlet maximum_edge_of_baking_over_staking_billionth =\n (* max is 1 (1_000_000_000 billionth) *)\n 1_000_000_000l\n\nlet default =\n {\n limit_of_staking_over_baking_millionth = 0l;\n edge_of_baking_over_staking_billionth = 1_000_000_000l;\n }\n\ntype error += Invalid_staking_parameters\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"operations.invalid_staking_parameters\"\n ~title:\"Invalid parameters for staking parameters\"\n ~description:\"The staking parameters are invalid.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Invalid staking parameters\")\n Data_encoding.empty\n (function Invalid_staking_parameters -> Some () | _ -> None)\n (fun () -> Invalid_staking_parameters)\n\nlet make ~limit_of_staking_over_baking_millionth\n ~edge_of_baking_over_staking_billionth =\n if\n Compare.Int32.(limit_of_staking_over_baking_millionth < 0l)\n || Compare.Int32.(edge_of_baking_over_staking_billionth < 0l)\n || Compare.Int32.(\n edge_of_baking_over_staking_billionth\n > maximum_edge_of_baking_over_staking_billionth)\n then Error ()\n else\n Ok\n {\n limit_of_staking_over_baking_millionth;\n edge_of_baking_over_staking_billionth;\n }\n\nlet encoding =\n let open Data_encoding in\n conv_with_guard\n (fun {\n limit_of_staking_over_baking_millionth;\n edge_of_baking_over_staking_billionth;\n } ->\n ( limit_of_staking_over_baking_millionth,\n edge_of_baking_over_staking_billionth ))\n (fun ( limit_of_staking_over_baking_millionth,\n edge_of_baking_over_staking_billionth ) ->\n Result.map_error\n (fun () -> \"Invalid staking parameters\")\n (make\n ~limit_of_staking_over_baking_millionth\n ~edge_of_baking_over_staking_billionth))\n (obj2\n (req \"limit_of_staking_over_baking_millionth\" int32)\n (req \"edge_of_baking_over_staking_billionth\" int32))\n\nlet make ~limit_of_staking_over_baking_millionth\n ~edge_of_baking_over_staking_billionth =\n match\n if\n Compare.Z.(limit_of_staking_over_baking_millionth < Z.zero)\n || Compare.Z.(edge_of_baking_over_staking_billionth < Z.zero)\n || not (Z.fits_int32 edge_of_baking_over_staking_billionth)\n then Error ()\n else\n let limit_of_staking_over_baking_millionth =\n if Z.fits_int32 limit_of_staking_over_baking_millionth then\n Z.to_int32 limit_of_staking_over_baking_millionth\n else Int32.max_int\n in\n let edge_of_baking_over_staking_billionth =\n Z.to_int32 edge_of_baking_over_staking_billionth\n in\n make\n ~limit_of_staking_over_baking_millionth\n ~edge_of_baking_over_staking_billionth\n with\n | Error () -> Result_syntax.tzfail Invalid_staking_parameters\n | Ok _ as ok -> ok\n" ;
} ;
{ name = "Misbehaviour_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** Which double signing event has occurred. *)\ntype kind = Double_baking | Double_attesting | Double_preattesting\n\n(** Internal representation of a double signing event used in\n {!Denunciations_repr.item}.\n\n For a double baking event, the [level] and [round] are those of\n both duplicate blocks. For a double (pre)attestating event, the\n [level] and [round] are those that appear in the\n {!Operation_repr.consensus_content} of both duplicate consensus\n operations.\n\n Note: the culprit pkh doesn't appear as a field here because it is\n typically used as a key when storing denunciation items in the\n context. *)\ntype t = {level : Raw_level_repr.t; round : Round_repr.t; kind : kind}\n\nval kind_encoding : kind Data_encoding.t\n\nval encoding : t Data_encoding.t\n\n(** Comparison function for double signing kinds.\n\n [Double_baking < Double_attesting < Double_preattesting] *)\nval compare_kind : kind -> kind -> int\n\nval equal_kind : kind -> kind -> bool\n\n(** Comparison function for misbehaviours.\n\n Misbehaviours are ordered by increasing level, then increasing\n round, then kind using {!compare_kind}. *)\nval compare : t -> t -> int\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype kind = Double_baking | Double_attesting | Double_preattesting\n\nlet kind_encoding =\n let open Data_encoding in\n string_enum\n [\n (\"preattestation\", Double_preattesting);\n (\"attestation\", Double_attesting);\n (\"block\", Double_baking);\n ]\n\ntype t = {level : Raw_level_repr.t; round : Round_repr.t; kind : kind}\n\nlet compare_kind a b =\n let to_int = function\n | Double_baking -> 0\n | Double_attesting -> 1\n | Double_preattesting -> 2\n in\n Compare.Int.compare (to_int a) (to_int b)\n\nlet equal_kind a b = Compare.Int.equal 0 (compare_kind a b)\n\nlet compare a b =\n Compare.or_else (Raw_level_repr.compare a.level b.level) @@ fun () ->\n Compare.or_else (Round_repr.compare a.round b.round) @@ fun () ->\n compare_kind a.kind b.kind\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {level; round; kind} -> (level, round, kind))\n (fun (level, round, kind) -> {level; round; kind})\n (obj3\n (req \"level\" Raw_level_repr.encoding)\n (req \"round\" Round_repr.encoding)\n (req \"kind\" kind_encoding))\n" ;
} ;
{ name = "Denunciations_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** Internal representation of a pending denunciation, meaning that a\n denunciation operation has been observed in an applied block, but\n the corresponding slashing has not happened yet.\n\n Note: the public key hash of the culprit doesn't appear in this\n type because it is used as key to store the list of a culprit's\n items (see type [t] below) in the context. *)\ntype item = {\n operation_hash : Operation_hash.t;\n rewarded : Signature.public_key_hash;\n misbehaviour : Misbehaviour_repr.t;\n}\n\n(** List of all pending denunciations about the same culprit. *)\ntype t = item list\n\nval item_encoding : item Data_encoding.t\n\nval encoding : t Data_encoding.t\n\n(** Append a new pending denunciation to the end of the given list. *)\nval add :\n Operation_hash.t -> Signature.public_key_hash -> Misbehaviour_repr.t -> t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype item = {\n operation_hash : Operation_hash.t;\n rewarded : Signature.public_key_hash;\n misbehaviour : Misbehaviour_repr.t;\n}\n\nlet item_encoding =\n let open Data_encoding in\n conv\n (fun {operation_hash; rewarded; misbehaviour} ->\n (operation_hash, rewarded, misbehaviour))\n (fun (operation_hash, rewarded, misbehaviour) ->\n {operation_hash; rewarded; misbehaviour})\n (obj3\n (req \"operation_hash\" Operation_hash.encoding)\n (req \"rewarded\" Signature.Public_key_hash.encoding)\n (req \"misbehaviour\" Misbehaviour_repr.encoding))\n\ntype t = item list\n\nlet encoding = Data_encoding.list item_encoding\n\nlet add operation_hash rewarded misbehaviour list =\n list @ [{operation_hash; rewarded; misbehaviour}]\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 [let+ l = list t k in List.length l] 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(** The internal message to be injected into the smart rollups\226\128\153 shared\n inbox when validating the very first block of this protocol. *)\nval protocol_migration_internal_message :\n Sc_rollup_inbox_message_repr.internal_inbox_message\n\n(** Serialized version of {!protocol_migration_internal_message}. *)\nval protocol_migration_serialized_message :\n Sc_rollup_inbox_message_repr.serialized\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 adaptive_issuance_enable:bool ->\n Context.t ->\n t tzresult Lwt.t\n\ntype previous_protocol = Genesis of Parameters_repr.t | ParisB_019\n\nval prepare_first_block :\n level:int32 ->\n timestamp:Time.t ->\n Chain_id.t ->\n Context.t ->\n (previous_protocol * Constants_parametric_previous_repr.t option * t) tzresult\n 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 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.\n\n @return [Error Sampler_already_set] if the sampler was already\n cached. *)\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 -> Stake_repr.t Signature.Public_key_hash.Map.t tzresult\n\n(** Like [stake_distribution_for_current_cycle] but returns [None] rather than\n an error. *)\nval find_stake_distribution_for_current_cycle :\n t -> Stake_repr.t Signature.Public_key_hash.Map.t option\n\nval init_stake_distribution_for_current_cycle :\n t -> Stake_repr.t Signature.Public_key_hash.Map.t -> t\n\n(** Returns the reward coefficient for the current cycle\n This value is equal to the value in {!Storage.Issuance_coeff} if it exists,\n or equal to [Q.one] otherwise. *)\nval reward_coeff_for_current_cycle : t -> Q.t\n\n(** Updates the reward coefficient for the current cycle.\n This update should only be called once per cycle. It is done in\n [Adaptive_issuance_storage] *)\nval update_reward_coeff_for_current_cycle : t -> Q.t -> t\n\n(** Returns true if adaptive issuance has launched. *)\nval adaptive_issuance_enable : t -> bool\n\n(** Set the feature flag of adaptive issuance. *)\nval set_adaptive_issuance_enable : 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 from the initial slot of each attester in the TB\n committee for a given level, to the attester's public key and its\n consensus power and DAL power. *)\n val allowed_attestations : t -> (consensus_pk * int * int) slot_map option\n\n (** See {!allowed_attestations}. *)\n val allowed_preattestations : t -> (consensus_pk * int * int) slot_map option\n\n (** Returns the set of delegates that are not allowed to bake or\n attest blocks; i.e., delegates which have zero frozen deposit\n due to a previous slashing. *)\n val forbidden_delegates : t -> Signature.Public_key_hash.Set.t\n\n (** Missing pre-computed map by first slot. This error should not happen. *)\n type error += Slot_map_not_found of {loc : string}\n\n (** [attestation power ctx] returns the attestation power of the\n current block. *)\n val current_attestation_power : t -> int\n\n (** Initializes the map of allowed attestations and preattestations, this\n function must be called only once and before applying any consensus\n operation. *)\n val initialize_consensus_operation :\n t ->\n allowed_attestations:(consensus_pk * int * int) slot_map option ->\n allowed_preattestations:(consensus_pk * int * int) slot_map option ->\n t\n\n (** [record_attestation ctx ~initial_slot ~power] records an\n attestation for the current block.\n\n The attestation should be valid in the sense that\n [Int_map.find_opt initial_slot allowed_attestation ctx = Some\n (pkh, power)]. *)\n val record_attestation : t -> initial_slot:slot -> power:int -> t tzresult\n\n (** [record_preattestation ctx ~initial_slot ~power round\n payload_hash power] records a preattestation for a proposal at\n [round] with payload [payload_hash].\n\n The preattestation should be valid in the sense that\n [Int_map.find_opt initial_slot allowed_preattestation ctx = Some\n (pkh, power)]. *)\n val record_preattestation :\n t -> initial_slot:slot -> power:int -> round -> t tzresult\n\n (** [forbid_delegate ctx delegate] adds [delegate] to the set of\n forbidden delegates, which prevents this delegate from baking or\n attesting. *)\n val forbid_delegate : t -> Signature.Public_key_hash.t -> t\n\n (** [set_forbidden_delegate ctx delegates] sets [delegates] as the\n current forbidden delegates. *)\n val set_forbidden_delegates : t -> Signature.Public_key_hash.Set.t -> t\n\n val attestations_seen : t -> slot_set\n\n (** [get_preattestations_quorum_round ctx] returns [None] if no\n preattestation are included in the current block. Otherwise,\n return [Some r] where [r] is the round of the preattestations\n included in the block. *)\n val get_preattestations_quorum_round : t -> round option\n\n (** [set_preattestations_quorum_round ctx round] sets the round for\n preattestations 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_preattestations_quorum_round : t -> round -> t\n\n (** [locked_round_evidence ctx] returns the round of the recorded\n preattestations as well as their power. *)\n val locked_round_evidence : t -> (round * int) option\n\n val set_attestation_branch : t -> Block_hash.t * Block_payload_hash.t -> t\n\n val attestation_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 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 type cryptobox = Dal.t\n\n val make : t -> (t * cryptobox) tzresult\n\n val number_of_slots : t -> int\n\n val number_of_shards : t -> int\n\n (** [record_number_of_attested_shards ctxt attestation number_of_shards]\n records that the [number_of_shards] shards were attested (declared\n available by some attester). *)\n val record_number_of_attested_shards : t -> Dal_attestation_repr.t -> int -> 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 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_attested 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_attested : t -> Dal_slot_index_repr.t -> bool\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_attestation_power : int;\n (** Number of attestation slots recorded for the current block. *)\n allowed_attestations : (consensus_pk * int * int) Slot_repr.Map.t option;\n (** Attestations rights for the current block. Only an attestation for\n the lowest slot in the block can be recorded. The map associates to\n each initial slot the [pkh] associated to this slot with its\n consensus attestation power and DAL attestation power. This is\n [None] only in mempool mode. *)\n allowed_preattestations : (consensus_pk * int * int) Slot_repr.Map.t option;\n (** Preattestations rights for the current block. Only a preattestation\n for the lowest slot in the block can be recorded. The map associates\n to each initial slot the [pkh] associated to this slot with its\n consensus attestation power and DAL attestation power. This is\n [None] only in mempool mode, or in application mode when there is no\n locked round (so the block cannot contain any preattestations). *)\n forbidden_delegates : Signature.Public_key_hash.Set.t;\n (** Delegates that are not allowed to bake or attest blocks; i.e.,\n delegates which have zero frozen deposit due to a previous\n slashing. *)\n attestations_seen : Slot_repr.Set.t;\n (** Record the attestations already seen. Only initial slots are indexed. *)\n preattestations_seen : Slot_repr.Set.t;\n (** Record the preattestations already seen. Only initial slots\n are indexed. *)\n locked_round_evidence : (Round_repr.t * int) option;\n (** Record the preattestation power for a locked round. *)\n preattestations_quorum_round : Round_repr.t option;\n (** in block construction mode, record the round of preattestations\n included in a block. *)\n attestation_branch : (Block_hash.t * Block_payload_hash.t) option;\n }\n\n (** Invariant:\n\n - [slot \\in attestations_seen => Int_map.mem slot allowed_attestations]\n\n - [slot \\in preattestations_seen => Int_map.mem slot allowed_preattestations]\n\n - [ |attestations_seen| > 0 => |included attestations| > 0]\n\n *)\n\n let empty : t =\n {\n current_attestation_power = 0;\n allowed_attestations = Some Slot_repr.Map.empty;\n allowed_preattestations = Some Slot_repr.Map.empty;\n forbidden_delegates = Signature.Public_key_hash.Set.empty;\n attestations_seen = Slot_repr.Set.empty;\n preattestations_seen = Slot_repr.Set.empty;\n locked_round_evidence = None;\n preattestations_quorum_round = None;\n attestation_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_attestation t ~initial_slot ~power =\n let open Result_syntax in\n let+ () =\n error_when\n (Slot_repr.Set.mem initial_slot t.attestations_seen)\n Double_inclusion_of_consensus_operation\n in\n {\n t with\n current_attestation_power = t.current_attestation_power + power;\n attestations_seen = Slot_repr.Set.add initial_slot t.attestations_seen;\n }\n\n let record_preattestation ~initial_slot ~power round t =\n let open Result_syntax in\n let+ () =\n error_when\n (Slot_repr.Set.mem initial_slot t.preattestations_seen)\n Double_inclusion_of_consensus_operation\n in\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 preattestations_seen =\n Slot_repr.Set.add initial_slot t.preattestations_seen;\n }\n\n let set_forbidden_delegates delegates t =\n {t with forbidden_delegates = delegates}\n\n let forbid_delegate delegate t =\n {\n t with\n forbidden_delegates =\n Signature.Public_key_hash.Set.add delegate t.forbidden_delegates;\n }\n\n let set_preattestations_quorum_round round t =\n match t.preattestations_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 preattestations_quorum_round = Some round}\n\n let initialize_with_attestations_and_preattestations ~allowed_attestations\n ~allowed_preattestations t =\n {t with allowed_attestations; allowed_preattestations}\n\n let locked_round_evidence t = t.locked_round_evidence\n\n let attestation_branch t = t.attestation_branch\n\n let set_attestation_branch t attestation_branch =\n {t with attestation_branch = Some attestation_branch}\nend\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 Stake_repr.t Signature.Public_key_hash.Map.t option;\n reward_coeff_for_current_cycle : Q.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_cryptobox : Dal.t option;\n adaptive_issuance_enable : bool;\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] 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] reward_coeff_for_current_cycle ctxt =\n ctxt.back.reward_coeff_for_current_cycle\n\nlet[@inline] adaptive_issuance_enable ctxt = ctxt.back.adaptive_issuance_enable\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\nlet[@inline] update_reward_coeff_for_current_cycle ctxt\n reward_coeff_for_current_cycle =\n update_back ctxt {ctxt.back with reward_coeff_for_current_cycle}\n\nlet[@inline] set_adaptive_issuance_enable ctxt =\n update_back ctxt {ctxt.back with adaptive_issuance_enable = true}\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 let open Result_syntax in\n if Compare.Int.(internal_nonce ctxt >= 65_535) then\n tzfail Too_many_internal_operations\n else\n return\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 open Result_syntax in\n let previous = get_collected_fees ctxt in\n let+ fees = Tez_repr.(previous +? fees') in\n update_fees ctxt fees\n\nlet spend_collected_fees_only_call_from_token ctxt fees' =\n let open Result_syntax in\n let previous = get_collected_fees ctxt in\n let+ fees = Tez_repr.(previous -? fees') in\n 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 let open Result_syntax in\n match origination_nonce ctxt with\n | None -> tzfail 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 return (ctxt, cur_origination_nonce)\n\nlet get_origination_nonce ctxt =\n let open Result_syntax in\n match origination_nonce ctxt with\n | None -> tzfail Undefined_operation_nonce\n | Some origination_nonce -> return 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 let open Result_syntax in\n let* () =\n check_gas_limit\n ~hard_gas_limit_per_operation:\n (constants ctxt).hard_gas_limit_per_operation\n ~gas_limit\n in\n let block_gas = block_gas_level ctxt in\n let limit = Arith.fp gas_limit in\n if Arith.(limit > block_gas) then tzfail 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 let open Result_syntax in\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 return ctxt\n else tzfail Operation_quota_exceeded\n\nlet check_enough_gas ctxt cost =\n let open Result_syntax in\n let* (_ : t) = consume_gas ctxt cost in\n 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 = Result_syntax.tzfail (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. *)\n\nlet protocol_migration_internal_message =\n Sc_rollup_inbox_message_repr.Protocol_migration Constants_repr.version_value\n\nlet protocol_migration_serialized_message =\n match\n Sc_rollup_inbox_message_repr.serialize\n (Internal protocol_migration_internal_message)\n with\n | Ok msg -> msg\n | Error trace ->\n Format.kasprintf\n failwith\n \"%s: Could not serialize protocol message : %a\"\n __LOC__\n pp_trace\n trace\n\nlet cycle_eras_key = [Constants_repr.version; \"cycle_eras\"]\n\nlet constants_key = [Constants_repr.version; \"constants\"]\n\nlet protocol_param_key = [\"protocol_parameters\"]\n\nlet get_cycle_eras ctxt =\n let open Lwt_syntax in\n let+ bytes_opt = Context.find ctxt cycle_eras_key in\n match bytes_opt with\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 open Lwt_result_syntax in\n let bytes =\n Data_encoding.Binary.to_bytes_exn Level_repr.cycle_eras_encoding cycle_eras\n in\n let*! ctxt = Context.add ctxt cycle_eras_key bytes in\n return ctxt\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 let open Lwt_result_syntax in\n let*! bytes_opt = Context.find ctxt protocol_param_key in\n match bytes_opt with\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 let*! ctxt = Context.remove ctxt protocol_param_key in\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 let*? () = Parameters_repr.check_params param in\n return (param, ctxt)))\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 let open Lwt_result_syntax in\n let*! bytes_opt = Context.find ctxt constants_key in\n match bytes_opt with\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 -> return constants)\n\nlet patch_constants ctxt f =\n let open Lwt_syntax in\n let constants = f (constants ctxt) in\n let+ context = add_constants (context ctxt) constants in\n let ctxt = update_context ctxt context in\n update_constants ctxt constants\n\nlet check_inited ctxt =\n let open Lwt_syntax in\n let+ bytes_opt = Context.find ctxt version_key in\n match bytes_opt with\n | None -> failwith \"Internal error: un-initialized context.\"\n | Some bytes ->\n let s = Bytes.to_string bytes in\n if Compare.String.(s = Constants_repr.version_value) then\n 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 ~adaptive_issuance_enable\n ctxt =\n let open Lwt_result_syntax in\n let*? level = Raw_level_repr.of_int32 level in\n let* () = check_inited ctxt in\n let* constants = get_constants ctxt in\n let*? round_durations =\n Round_repr.Durations.create\n ~first_round_duration:constants.minimal_block_delay\n ~delay_increment_per_round:constants.delay_increment_per_round\n in\n let+ cycle_eras = get_cycle_eras ctxt in\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 reward_coeff_for_current_cycle = Q.one;\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 ~number_of_slots:\n constants.Constants_parametric_repr.dal.number_of_slots;\n dal_cryptobox = None;\n adaptive_issuance_enable;\n };\n }\n\ntype previous_protocol = Genesis of Parameters_repr.t | ParisB_019\n\nlet check_and_update_protocol_version ctxt =\n let open Lwt_result_syntax in\n let* previous_proto, ctxt =\n let*! bytes_opt = Context.find ctxt version_key in\n match bytes_opt with\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 = Constants_repr.version_value) then\n failwith \"Internal error: previously initialized context.\"\n else if Compare.String.(s = \"genesis\") then\n let+ param, ctxt = get_proto_param ctxt in\n (Genesis param, ctxt)\n else if Compare.String.(s = \"paris_019\") then return (ParisB_019, ctxt)\n else Lwt.return @@ storage_error (Incompatible_protocol_version s)\n in\n let*! ctxt =\n Context.add ctxt version_key (Bytes.of_string Constants_repr.version_value)\n in\n return (previous_proto, ctxt)\n\n(* only for the migration *)\nlet[@warning \"-32\"] get_previous_protocol_constants ctxt =\n let open Lwt_syntax in\n let* bytes_opt = Context.find ctxt constants_key in\n match bytes_opt with\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 -> return constants)\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 _chain_id ctxt =\n let open Lwt_result_syntax in\n let* previous_proto, ctxt = check_and_update_protocol_version ctxt in\n let* ctxt, previous_proto_constants =\n match previous_proto with\n | Genesis param ->\n let*? first_level = Raw_level_repr.of_int32 level in\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 let*? cycle_eras = Level_repr.create_cycle_eras [cycle_era] in\n let* ctxt = set_cycle_eras ctxt cycle_eras in\n let*! result = add_constants ctxt param.constants in\n return (result, None)\n | ParisB_019 ->\n let*! c = get_previous_protocol_constants ctxt in\n let dal =\n let Constants_parametric_previous_repr.\n {\n feature_enable;\n incentives_enable;\n number_of_slots;\n attestation_lag;\n attestation_threshold;\n cryptobox_parameters;\n } =\n c.dal\n in\n Constants_parametric_repr.\n {\n feature_enable;\n incentives_enable;\n number_of_slots;\n attestation_lag;\n attestation_threshold;\n cryptobox_parameters;\n }\n in\n let sc_rollup =\n let Constants_parametric_previous_repr.\n {\n arith_pvm_enable;\n origination_size;\n challenge_window_in_blocks;\n stake_amount;\n commitment_period_in_blocks;\n max_lookahead_in_blocks;\n max_active_outbox_levels;\n max_outbox_messages_per_level;\n number_of_sections_in_dissection;\n timeout_period_in_blocks;\n max_number_of_stored_cemented_commitments;\n max_number_of_parallel_games;\n reveal_activation_level =\n {\n raw_data = {blake2B};\n metadata;\n dal_page;\n dal_parameters;\n dal_attested_slots_validity_lag;\n };\n private_enable;\n riscv_pvm_enable;\n } =\n c.sc_rollup\n in\n Constants_parametric_repr.\n {\n arith_pvm_enable;\n origination_size;\n challenge_window_in_blocks;\n stake_amount;\n commitment_period_in_blocks;\n max_lookahead_in_blocks;\n max_active_outbox_levels;\n max_outbox_messages_per_level;\n number_of_sections_in_dissection;\n timeout_period_in_blocks;\n max_number_of_stored_cemented_commitments;\n max_number_of_parallel_games;\n reveal_activation_level =\n {\n raw_data = {blake2B};\n metadata;\n dal_page;\n dal_parameters;\n dal_attested_slots_validity_lag;\n };\n private_enable;\n riscv_pvm_enable;\n }\n in\n let zk_rollup =\n let Constants_parametric_previous_repr.\n {\n enable;\n origination_size;\n min_pending_to_process;\n max_ticket_payload_size;\n } =\n c.zk_rollup\n in\n Constants_parametric_repr.\n {\n enable;\n origination_size;\n min_pending_to_process;\n max_ticket_payload_size;\n }\n in\n\n let adaptive_issuance =\n let Constants_parametric_previous_repr.\n {\n global_limit_of_staking_over_baking;\n edge_of_staking_over_delegation;\n launch_ema_threshold;\n adaptive_rewards_params =\n {\n issuance_ratio_final_max;\n issuance_ratio_final_min;\n issuance_ratio_initial_min;\n issuance_ratio_initial_max;\n initial_period;\n transition_period;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n };\n activation_vote_enable;\n autostaking_enable;\n force_activation;\n ns_enable;\n } =\n c.adaptive_issuance\n in\n Constants_parametric_repr.\n {\n global_limit_of_staking_over_baking;\n edge_of_staking_over_delegation;\n launch_ema_threshold;\n adaptive_rewards_params =\n {\n issuance_ratio_final_max;\n issuance_ratio_final_min;\n issuance_ratio_initial_min;\n issuance_ratio_initial_max;\n initial_period;\n transition_period;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n };\n activation_vote_enable;\n autostaking_enable;\n force_activation;\n ns_enable;\n }\n in\n let (issuance_weights : Constants_parametric_repr.issuance_weights) =\n let Constants_parametric_previous_repr.\n {\n base_total_issued_per_minute;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n } =\n c.issuance_weights\n in\n Constants_parametric_repr.\n {\n base_total_issued_per_minute;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n }\n in\n let constants =\n Constants_parametric_repr.\n {\n consensus_rights_delay = c.consensus_rights_delay;\n blocks_preservation_cycles = c.blocks_preservation_cycles;\n delegate_parameters_activation_delay =\n c.delegate_parameters_activation_delay;\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 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 minimal_frozen_stake = c.minimal_frozen_stake;\n vdf_difficulty = c.vdf_difficulty;\n origination_size = c.origination_size;\n max_operations_time_to_live = c.max_operations_time_to_live;\n issuance_weights;\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 limit_of_delegation_over_baking =\n c.limit_of_delegation_over_baking;\n percentage_of_frozen_deposits_slashed_per_double_baking =\n c.percentage_of_frozen_deposits_slashed_per_double_baking;\n percentage_of_frozen_deposits_slashed_per_double_attestation =\n c.percentage_of_frozen_deposits_slashed_per_double_attestation;\n max_slashing_per_block = c.max_slashing_per_block;\n max_slashing_threshold = c.max_slashing_threshold;\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 =\n c.cache_stake_distribution_cycles;\n cache_sampler_state_cycles = c.cache_sampler_state_cycles;\n dal;\n sc_rollup;\n zk_rollup;\n adaptive_issuance;\n direct_ticket_spending_enable = c.direct_ticket_spending_enable;\n }\n in\n let*! ctxt = add_constants ctxt constants in\n return (ctxt, Some c)\n in\n let+ ctxt =\n prepare\n ctxt\n ~level\n ~predecessor_timestamp:timestamp\n ~timestamp\n ~adaptive_issuance_enable:false\n in\n (previous_proto, previous_proto_constants, ctxt)\n\nlet activate ctxt h =\n let open Lwt_syntax in\n let+ new_ctxt = Updater.activate (context ctxt) h in\n update_context ctxt new_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 let open Lwt_result_syntax in\n let*! v_opt = Context.find (context ctxt) k in\n match v_opt with\n | None -> Lwt.return @@ storage_error (Missing_key (k, Get))\n | Some v -> return v\n\nlet get_tree ctxt k =\n let open Lwt_result_syntax in\n let*! v_opt = Context.find_tree (context ctxt) k in\n match v_opt with\n | None -> Lwt.return @@ storage_error (Missing_key (k, Get))\n | Some v -> return 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 =\n let open Lwt_syntax in\n let+ new_ctxt = Context.add (context ctxt) k v in\n update_context ctxt new_ctxt\n\nlet add_tree ctxt k v =\n let open Lwt_syntax in\n let+ new_ctxt = Context.add_tree (context ctxt) k v in\n update_context ctxt new_ctxt\n\nlet init ctxt k v =\n let open Lwt_result_syntax in\n let*! result = Context.mem (context ctxt) k in\n match result with\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ ->\n let*! context = Context.add (context ctxt) k v in\n return (update_context ctxt context)\n\nlet init_tree ctxt k v : _ tzresult Lwt.t =\n let open Lwt_result_syntax in\n let*! result = Context.mem_tree (context ctxt) k in\n match result with\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ ->\n let*! context = Context.add_tree (context ctxt) k v in\n return (update_context ctxt context)\n\nlet update ctxt k v =\n let open Lwt_result_syntax in\n let*! result = Context.mem (context ctxt) k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ ->\n let*! context = Context.add (context ctxt) k v in\n return (update_context ctxt context)\n\nlet update_tree ctxt k v =\n let open Lwt_result_syntax in\n let*! result = Context.mem_tree (context ctxt) k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ ->\n let*! context = Context.add_tree (context ctxt) k v in\n return (update_context ctxt context)\n\n(* Verify that the key is present before deleting *)\nlet remove_existing ctxt k =\n let open Lwt_result_syntax in\n let*! result = Context.mem (context ctxt) k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ ->\n let*! context = Context.remove (context ctxt) k in\n return (update_context ctxt context)\n\n(* Verify that the key is present before deleting *)\nlet remove_existing_tree ctxt k =\n let open Lwt_result_syntax in\n let*! result = Context.mem_tree (context ctxt) k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ ->\n let*! context = Context.remove (context ctxt) k in\n return (update_context ctxt context)\n\n(* Do not verify before deleting *)\nlet remove ctxt k =\n let open Lwt_syntax in\n let+ new_ctxt = Context.remove (context ctxt) k in\n update_context ctxt new_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 let open Lwt_result_syntax in\n let*! result = find t k in\n match result with\n | None -> Lwt.return @@ storage_error (Missing_key (k, Get))\n | Some v -> return v\n\n let get_tree t k =\n let open Lwt_result_syntax in\n let*! result = find_tree t k in\n match result with\n | None -> Lwt.return @@ storage_error (Missing_key (k, Get))\n | Some v -> return v\n\n let init t k v =\n let open Lwt_result_syntax in\n let*! result = mem t k in\n match result with\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ ->\n let*! tree = add t k v in\n return tree\n\n let init_tree t k v =\n let open Lwt_result_syntax in\n let*! result = mem_tree t k in\n match result with\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ ->\n let*! tree = add_tree t k v in\n return tree\n\n let update t k v =\n let open Lwt_result_syntax in\n let*! result = mem t k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ ->\n let*! tree = add t k v in\n return tree\n\n let update_tree t k v =\n let open Lwt_result_syntax in\n let*! result = mem_tree t k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ ->\n let*! tree = add_tree t k v in\n return tree\n\n (* Verify that the key is present before deleting *)\n let remove_existing t k =\n let open Lwt_result_syntax in\n let*! result = mem t k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ ->\n let*! tree = remove t k in\n return tree\n\n (* Verify that the key is present before deleting *)\n let remove_existing_tree t k =\n let open Lwt_result_syntax in\n let*! result = mem_tree t k in\n match result with\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ ->\n let*! tree = remove t k in\n return tree\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 let open Lwt_syntax in\n let+ ctxt, temporary_lazy_storage_ids = f (temporary_lazy_storage_ids ctxt) in\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 let open Lwt_syntax in\n let+ ctxt = Context.Cache.set_cache_layout (context c) layout in\n 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 let open Lwt_syntax in\n let+ ctxt = Context.Cache.sync (context c) ~cache_nonce in\n 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 open Result_syntax in\n let map = sampler_state ctxt in\n if Cycle_repr.Map.mem cycle map then tzfail (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 return ctxt\n\nlet sampler_for_cycle ~read ctxt cycle =\n let open Lwt_result_syntax in\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 let* seed, state = read ctxt in\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 find_stake_distribution_for_current_cycle ctxt =\n ctxt.back.stake_distribution_for_current_cycle\n\nlet stake_distribution_for_current_cycle ctxt =\n let open Result_syntax in\n match ctxt.back.stake_distribution_for_current_cycle with\n | None -> tzfail Stake_distribution_not_set\n | Some s -> return 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_attestations : t -> (consensus_pk * int * int) slot_map option\n\n val allowed_preattestations : t -> (consensus_pk * int * int) slot_map option\n\n val forbidden_delegates : t -> Signature.Public_key_hash.Set.t\n\n type error += Slot_map_not_found of {loc : string}\n\n val current_attestation_power : t -> int\n\n val initialize_consensus_operation :\n t ->\n allowed_attestations:(consensus_pk * int * int) slot_map option ->\n allowed_preattestations:(consensus_pk * int * int) slot_map option ->\n t\n\n val record_attestation : t -> initial_slot:slot -> power:int -> t tzresult\n\n val record_preattestation :\n t -> initial_slot:slot -> power:int -> round -> t tzresult\n\n val forbid_delegate : t -> Signature.Public_key_hash.t -> t\n\n val set_forbidden_delegates : t -> Signature.Public_key_hash.Set.t -> t\n\n val attestations_seen : t -> slot_set\n\n val get_preattestations_quorum_round : t -> round option\n\n val set_preattestations_quorum_round : t -> round -> t\n\n val locked_round_evidence : t -> (round * int) option\n\n val set_attestation_branch : t -> Block_hash.t * Block_payload_hash.t -> t\n\n val attestation_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] 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 let open Result_syntax in\n let+ consensus = f ctxt.back.consensus in\n {ctxt with back = {ctxt.back with consensus}}\n\n let[@inline] allowed_attestations ctxt =\n ctxt.back.consensus.allowed_attestations\n\n let[@inline] allowed_preattestations ctxt =\n ctxt.back.consensus.allowed_preattestations\n\n let[@inline] forbidden_delegates ctxt =\n ctxt.back.consensus.forbidden_delegates\n\n let[@inline] set_forbidden_delegates ctxt delegates =\n update_consensus_with ctxt (Raw_consensus.set_forbidden_delegates delegates)\n\n let[@inline] current_attestation_power ctxt =\n ctxt.back.consensus.current_attestation_power\n\n let[@inline] get_preattestations_quorum_round ctxt =\n ctxt.back.consensus.preattestations_quorum_round\n\n let[@inline] locked_round_evidence ctxt =\n Raw_consensus.locked_round_evidence ctxt.back.consensus\n\n let[@inline] initialize_consensus_operation ctxt ~allowed_attestations\n ~allowed_preattestations =\n update_consensus_with\n ctxt\n (Raw_consensus.initialize_with_attestations_and_preattestations\n ~allowed_attestations\n ~allowed_preattestations)\n\n let[@inline] record_preattestation ctxt ~initial_slot ~power round =\n update_consensus_with_tzresult\n ctxt\n (Raw_consensus.record_preattestation ~initial_slot ~power round)\n\n let[@inline] record_attestation ctxt ~initial_slot ~power =\n update_consensus_with_tzresult\n ctxt\n (Raw_consensus.record_attestation ~initial_slot ~power)\n\n let[@inline] forbid_delegate ctxt delegate =\n update_consensus_with ctxt (Raw_consensus.forbid_delegate delegate)\n\n let[@inline] attestations_seen ctxt = ctxt.back.consensus.attestations_seen\n\n let[@inline] set_preattestations_quorum_round ctxt round =\n update_consensus_with\n ctxt\n (Raw_consensus.set_preattestations_quorum_round round)\n\n let[@inline] attestation_branch ctxt =\n Raw_consensus.attestation_branch ctxt.back.consensus\n\n let[@inline] set_attestation_branch ctxt branch =\n update_consensus_with ctxt (fun ctxt ->\n Raw_consensus.set_attestation_branch ctxt branch)\n\n type error += Slot_map_not_found of {loc : string}\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"raw_context.consensus.slot_map_not_found\"\n ~title:\"Slot map not found\"\n ~description:\"Pre-computed map by first slot not found.\"\n Data_encoding.(obj1 (req \"loc\" (string Plain)))\n (function Slot_map_not_found {loc} -> Some loc | _ -> None)\n (fun loc -> Slot_map_not_found {loc})\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 cryptobox = Dal.t\n\n let make ctxt =\n let open Result_syntax in\n (* Dal.make takes some time (on the order of 10ms) so we memoize\n its result to avoid calling it more than once per block. *)\n match ctxt.back.dal_cryptobox with\n | Some cryptobox -> return (ctxt, cryptobox)\n | None -> (\n let Constants_parametric_repr.{dal = {cryptobox_parameters; _}; _} =\n ctxt.back.constants\n in\n match Dal.make cryptobox_parameters with\n | Ok cryptobox ->\n let back = {ctxt.back with dal_cryptobox = Some cryptobox} in\n return ({ctxt with back}, cryptobox)\n | Error (`Fail explanation) ->\n tzfail (Dal_errors_repr.Dal_cryptobox_error {explanation}))\n\n let number_of_slots ctxt = ctxt.back.constants.dal.number_of_slots\n\n let number_of_shards ctxt =\n ctxt.back.constants.dal.cryptobox_parameters.number_of_shards\n\n let record_number_of_attested_shards ctxt attestation number =\n let dal_attestation_slot_accountability =\n Dal_attestation_repr.Accountability.record_number_of_attested_shards\n ctxt.back.dal_attestation_slot_accountability\n attestation\n number\n in\n {ctxt with back = {ctxt.back with dal_attestation_slot_accountability}}\n\n let register_slot_header ctxt slot_header =\n let open Result_syntax in\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 tzfail\n (Dal_errors_repr.Dal_register_invalid_slot_header\n {length; slot_header})\n | Some (dal_slot_fee_market, updated) ->\n if not updated then\n tzfail\n (Dal_errors_repr.Dal_publish_commitment_duplicate {slot_header})\n else return {ctxt with back = {ctxt.back with dal_slot_fee_market}}\n\n let candidates ctxt =\n Dal_slot_repr.Slot_market.candidates ctxt.back.dal_slot_fee_market\n\n let is_slot_index_attested ctxt =\n let threshold =\n ctxt.back.constants.Constants_parametric_repr.dal.attestation_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_attested\n ctxt.back.dal_attestation_slot_accountability\n ~threshold\n ~number_of_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 let open Lwt_result_syntax in\n let*! tree_opt = find_tree ctxt key in\n let tree =\n match tree_opt with None -> Tree.empty ctxt | Some tree -> tree\n in\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 let* local_ctxt, res = f local_ctxt in\n let*! ctxt = add_tree ctxt key local_ctxt.tree in\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 -> return (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 let open Result_syntax in\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 return local\n else tzfail 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 let open Lwt_result_syntax in\n let+ tree = Tree.update (tree local) key b in\n update_root_tree local tree\n\n let update_tree local key b =\n let open Lwt_result_syntax in\n let+ tree = Tree.update_tree (tree local) key b in\n update_root_tree local tree\n\n let init local key b =\n let open Lwt_result_syntax in\n let+ tree = Tree.init (tree local) key b in\n update_root_tree local tree\n\n let init_tree local key t =\n let open Lwt_result_syntax in\n let+ tree = Tree.init_tree (tree local) key t in\n update_root_tree local tree\n\n let add local i b =\n let open Lwt_syntax in\n let+ tree = Tree.add (tree local) i b in\n update_root_tree local tree\n\n let add_tree local i t =\n let open Lwt_syntax in\n let+ tree = Tree.add_tree (tree local) i t in\n update_root_tree local tree\n\n let remove local i =\n let open Lwt_syntax in\n let+ tree = Tree.remove (tree local) i in\n update_root_tree local tree\n\n let remove_existing local key =\n let open Lwt_result_syntax in\n let+ tree = Tree.remove_existing (tree local) key in\n update_root_tree local tree\n\n let remove_existing_tree local key =\n let open Lwt_result_syntax in\n let+ tree = Tree.remove_existing_tree (tree local) key in\n update_root_tree local tree\n\n let add_or_remove local key vopt =\n let open Lwt_syntax in\n let+ tree = Tree.add_or_remove (tree local) key vopt in\n update_root_tree local tree\n\n let add_or_remove_tree local key topt =\n let open Lwt_syntax in\n let+ tree = Tree.add_or_remove_tree (tree local) key topt in\n update_root_tree local tree\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_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model storage/List_key_values *)\n(* fun size -> max 10 (470. + (117. * size)) *)\nlet cost_List_key_values size =\n let size = S.safe_int size in\n (size * S.safe_int 118) + S.safe_int 470\n\n(* model storage/List_key_values/intercept *)\n(* fun size -> max 10 (470. + (117. * size)) *)\nlet cost_intercept size =\n let size = S.safe_int size in\n (size * S.safe_int 118) + S.safe_int 470\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(* Copyright (c) 2023 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 Storage_costs_generated\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 open S.Syntax in\n Gas_limit_repr.atomic_step_cost\n @@ safe_int 200_000\n + (safe_int 5000 * safe_int path_length)\n + (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 let open S.Syntax in\n Gas_limit_repr.atomic_step_cost\n @@ (safe_int 200_000 + (safe_int 4 * safe_int written_bytes))\n\nlet list_key_values_traverse ~size = cost_List_key_values size\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 exist *)\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], deletes the storage bucket ; does\n nothing if the bucket does not exist. *)\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 exist *)\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 exist *)\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 exist. *)\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], deletes the storage bucket ; does\n nothing if the bucket does not exist. *)\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 exist. *)\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 exist. *)\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 exist.\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], deletes the storage bucket ; does\n nothing if the bucket does not exist\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 exist.\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 exist.\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 Consumes [Gas_repr.read_bytes_cost Z.zero].*)\n val is_empty : context -> (Raw_context.t * bool) tzresult Lwt.t\n\n (** [clear storage] removes all values from the storage.\n Consumes [Gas_repr.write_bytes_cost Z.zero] .*)\n val clear : context -> Raw_context.t tzresult 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 exist. *)\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 exist *)\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 an elt is a member of the set *)\n val mem : context -> elt -> bool Lwt.t\n\n (** Adds an elt as a member of the set *)\n val add : context -> elt -> Raw_context.t Lwt.t\n\n (** Removes an elt from 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 (** Returns true if and only if the set contains no elements.\n Consumes [Gas_repr.read_bytes_cost Z.zero].*)\n val is_empty : context -> (Raw_context.t * bool) tzresult Lwt.t\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 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 (** Removes all elt from the set.\n Consumes [Gas_repr.write_bytes_cost Z.zero].\n\n This function does not returns the freed size. This is because\n it would need to fold over all keys or add a size accumulator\n and no usage exists so far. *)\n val clear : context -> Raw_context.t 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 let open Result_syntax in\n match Data_encoding.Binary.of_bytes_opt V.encoding b with\n | None -> tzfail (Raw_context.Storage_error (Corrupted_data (key ())))\n | Some v -> return 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 let open Result_syntax in\n match Data_encoding.(Binary.of_bytes_opt int31) len with\n | None -> tzfail (Raw_context.Storage_error (Corrupted_data key))\n | Some len -> return 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 let open Lwt_result_syntax in\n let* b = C.get t N.name in\n let key () = C.absolute_key t N.name in\n let*? v = of_bytes ~key b in\n return v\n\n let find t =\n let open Lwt_result_syntax in\n let*! bytes_opt = C.find t N.name in\n match bytes_opt with\n | None -> return_none\n | Some b ->\n let key () = C.absolute_key t N.name in\n let*? v = of_bytes ~key b in\n return_some v\n\n let init t v =\n let open Lwt_result_syntax in\n let+ t = C.init t N.name (to_bytes v) in\n C.project t\n\n let update t v =\n let open Lwt_result_syntax in\n let+ t = C.update t N.name (to_bytes v) in\n C.project t\n\n let add t v =\n let open Lwt_syntax in\n let+ t = C.add t N.name (to_bytes v) in\n C.project t\n\n let add_or_remove t v =\n let open Lwt_syntax in\n let+ t = C.add_or_remove t N.name (Option.map to_bytes v) in\n C.project t\n\n let remove t =\n let open Lwt_syntax in\n let+ t = C.remove t N.name in\n C.project t\n\n let remove_existing t =\n let open Lwt_result_syntax in\n let+ t = C.remove_existing t N.name in\n 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 =\n let open Lwt_syntax in\n let+ t = C.add s (I.to_path i []) inited in\n C.project t\n\n let remove s i =\n let open Lwt_syntax in\n let+ t = C.remove s (I.to_path i []) in\n C.project t\n\n let clear s =\n let open Lwt_syntax in\n let+ t = C.remove s [] in\n 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 Lwt_result_syntax in\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 let*! result = mem c k in\n match result with true -> return_some true | false -> return_none)\n (register_indexed_subcontext\n ~list:(fun c ->\n let*! result = elements c in\n return result)\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 let open Lwt_result_syntax in\n let* b = C.get s (I.to_path i []) in\n let key () = C.absolute_key s (I.to_path i []) in\n let*? v = of_bytes ~key b in\n return v\n\n let find s i =\n let open Lwt_result_syntax in\n let*! bytes_opt = C.find s (I.to_path i []) in\n match bytes_opt with\n | None -> return_none\n | Some b ->\n let key () = C.absolute_key s (I.to_path i []) in\n let*? v = of_bytes ~key b in\n return_some v\n\n let update s i v =\n let open Lwt_result_syntax in\n let+ t = C.update s (I.to_path i []) (to_bytes v) in\n C.project t\n\n let init s i v =\n let open Lwt_result_syntax in\n let+ t = C.init s (I.to_path i []) (to_bytes v) in\n C.project t\n\n let add s i v =\n let open Lwt_syntax in\n let+ t = C.add s (I.to_path i []) (to_bytes v) in\n C.project t\n\n let add_or_remove s i v =\n let open Lwt_syntax in\n let+ t = C.add_or_remove s (I.to_path i []) (Option.map to_bytes v) in\n C.project t\n\n let remove s i =\n let open Lwt_syntax in\n let+ t = C.remove s (I.to_path i []) in\n C.project t\n\n let remove_existing s i =\n let open Lwt_result_syntax in\n let+ t = C.remove_existing s (I.to_path i []) in\n C.project t\n\n let clear s =\n let open Lwt_syntax in\n let+ t = C.remove s [] in\n C.project t\n\n let fold s ~order ~init ~f =\n let open Lwt_syntax in\n C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc ->\n let* bytes_opt = C.Tree.to_value tree in\n match bytes_opt with\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 _ -> return acc))\n | None -> 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 Lwt_result_syntax in\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 ->\n let*! result = keys c in\n return result)\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 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 let open Lwt_result_syntax in\n let*! bytes_opt = C.find c (len_key i) in\n match bytes_opt with\n | None -> return (0, false)\n | Some len ->\n let*? len = decode_len_value (len_key i) len in\n return (len, true)\n\n let consume_read_gas get c i =\n let open Lwt_result_syntax in\n let len_key = len_key i in\n let* len = get c len_key in\n let path_length = List.length @@ C.absolute_key c len_key in\n let*? read_bytes = decode_len_value len_key len in\n let cost = Storage_costs.read_access ~path_length ~read_bytes in\n let*? t = C.consume_gas c cost in\n return t\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 open Lwt_result_syntax in\n let bytes = to_bytes v in\n let len = Bytes.length bytes in\n let*? c = C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len) in\n let cost = Storage_costs.write_access ~written_bytes:len in\n let*? c = C.consume_gas c cost in\n let+ c = set c (len_key i) (encode_len_value bytes) in\n (c, bytes)\n\n let consume_remove_gas del c i =\n let open Lwt_result_syntax in\n let*? c = C.consume_gas c (Storage_costs.write_access ~written_bytes:0) in\n del c (len_key i)\n\n let mem s i =\n let open Lwt_result_syntax in\n let key = data_key i in\n let*? s = consume_mem_gas s key in\n let*! exists = C.mem s key in\n return (C.project s, exists)\n\n let is_empty s =\n let open Lwt_result_syntax in\n let root_key = [] in\n let*? s = consume_mem_gas s root_key in\n let*! root_opt = C.find_tree s root_key in\n match root_opt with\n | None -> return @@ (C.project s, true)\n | Some root ->\n let is_empty = C.Tree.is_empty root in\n return @@ (C.project s, is_empty)\n\n let get_unprojected s i =\n let open Lwt_result_syntax in\n let* s = consume_read_gas C.get s i in\n let* b = C.get s (data_key i) in\n let key () = C.absolute_key s (data_key i) in\n let*? v = of_bytes ~key b in\n return (s, v)\n\n let get s i =\n let open Lwt_result_syntax in\n let+ s, v = get_unprojected s i in\n (C.project s, v)\n\n let find s i =\n let open Lwt_result_syntax in\n let key = data_key i in\n let*? s = consume_mem_gas s key in\n let*! exists = C.mem s key in\n if exists then\n let+ s, v = get s i in\n (s, Some v)\n else return (C.project s, None)\n\n let update s i v =\n let open Lwt_result_syntax in\n let* prev_size, _ = existing_size s i in\n let* s, bytes = consume_serialize_write_gas C.update s i v in\n let+ t = C.update s (data_key i) bytes in\n let size_diff = Bytes.length bytes - prev_size in\n (C.project t, size_diff)\n\n let init s i v =\n let open Lwt_result_syntax in\n let* s, bytes = consume_serialize_write_gas C.init s i v in\n let+ t = C.init s (data_key i) bytes in\n let size = Bytes.length bytes in\n (C.project t, size)\n\n let add s i v =\n let open Lwt_result_syntax in\n let add s i v =\n let*! ctxt = C.add s i v in\n return ctxt\n in\n let* prev_size, existed = existing_size s i in\n let* s, bytes = consume_serialize_write_gas add s i v in\n let+ t = add s (data_key i) bytes in\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 open Lwt_result_syntax in\n let remove s i =\n let*! ctxt = C.remove s i in\n return ctxt\n in\n let* prev_size, existed = existing_size s i in\n let* s = consume_remove_gas remove s i in\n let+ t = remove s (data_key i) in\n (C.project t, prev_size, existed)\n\n let clear s =\n let open Lwt_result_syntax in\n let*? s = C.consume_gas s (Storage_costs.write_access ~written_bytes:0) in\n let*! t = C.remove s [] in\n return (C.project t)\n\n let remove_existing s i =\n let open Lwt_result_syntax in\n let* prev_size, _ = existing_size s i in\n let* s = consume_remove_gas C.remove_existing s i in\n let+ t = C.remove_existing s (data_key i) in\n (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 open Lwt_result_syntax in\n let root = [] in\n let depth = `Eq I.path_length in\n let*! size = C.length s root in\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 let*? s = C.consume_gas s (Storage_costs.list_key_values_traverse ~size) in\n let+ s, rev_values, _offset, _length =\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 let+ s, value = get_unprojected s key in\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 in\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 open Lwt_result_syntax 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 let+ _, v = find c k in\n v)\n (register_indexed_subcontext\n ~list:(fun c ->\n let*! result = keys_unaccounted c in\n return result)\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 is_empty = M.is_empty\n\n let clear = M.clear\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 let open Lwt_result_syntax in\n let*! tree_opt = C.find_tree s data_name in\n match tree_opt with\n | None -> Lwt.return (err_missing_key data_name)\n | Some tree ->\n let*! t = C.add_tree s (snapshot_path id) tree in\n return (C.project t)\n\n let fold_snapshot s id ~order ~init ~f =\n let open Lwt_result_syntax in\n let*! tree_opt = C.find_tree s (snapshot_path id) in\n match tree_opt with\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 let*? acc in\n let*! bytes_opt = C.Tree.to_value tree in\n match bytes_opt with\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 let open Lwt_syntax in\n let+ t = C.remove s (snapshot_path id) in\n 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 =\n let open Lwt_syntax in\n let+ t = C.remove t [] in\n 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 open Lwt_result_syntax in\n let from = I.to_path from [] in\n let to_ = I.to_path to_ [] in\n let*! tree_opt = C.find_tree t from in\n match tree_opt with\n | None -> Lwt.return (err_missing_key from)\n | Some tree ->\n let*! ctxt = C.add_tree t to_ tree in\n return ctxt\n\n let remove t k = C.remove t (I.to_path k [])\n\n let description =\n let open Lwt_result_syntax in\n Storage_description.register_indexed_subcontext\n ~list:(fun c ->\n let*! result = keys c in\n return result)\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 open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t = C.init t (to_key i k) v in\n pack t i\n\n let init_tree c k v =\n let open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t = C.init_tree t (to_key i k) v in\n pack t i\n\n let update c k v =\n let open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t = C.update t (to_key i k) v in\n pack t i\n\n let update_tree c k v =\n let open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t = C.update_tree t (to_key i k) v in\n pack t i\n\n let add c k v =\n let open Lwt_syntax in\n let t, i = unpack c in\n let+ t = C.add t (to_key i k) v in\n pack t i\n\n let add_tree c k v =\n let open Lwt_syntax in\n let t, i = unpack c in\n let+ t = C.add_tree t (to_key i k) v in\n pack t i\n\n let add_or_remove c k v =\n let open Lwt_syntax in\n let t, i = unpack c in\n let+ t = C.add_or_remove t (to_key i k) v in\n pack t i\n\n let add_or_remove_tree c k v =\n let open Lwt_syntax in\n let t, i = unpack c in\n let+ t = C.add_or_remove_tree t (to_key i k) v in\n pack t i\n\n let remove_existing c k =\n let open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t = C.remove_existing t (to_key i k) in\n pack t i\n\n let remove_existing_tree c k =\n let open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t = C.remove_existing_tree t (to_key i k) in\n pack t i\n\n let remove c k =\n let open Lwt_syntax in\n let t, i = unpack c in\n let+ t = C.remove t (to_key i k) in\n 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 open Result_syntax in\n let t, i = unpack c in\n let* t = C.consume_gas t g in\n return (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 open Lwt_result_syntax in\n let t, i = unpack c in\n let+ t, res = C.with_local_context t (to_key i k) f in\n (pack t i, res)\n\n module Local_context = C.Local_context\n end\n\n let with_local_context s i f =\n let open Lwt_result_syntax in\n let+ c, x = Raw_context.with_local_context (pack s i) [] f in\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 let open Lwt_syntax in\n let+ c = Raw_context.add (pack s i) N.name inited in\n let s, _ = unpack c in\n C.project s\n\n let remove s i =\n let open Lwt_syntax in\n let+ c = Raw_context.remove (pack s i) N.name in\n let s, _ = unpack c in\n C.project s\n\n let clear s =\n let open Lwt_syntax in\n let+ t =\n fold_keys s ~init:s ~order:`Sorted ~f:(fun i s ->\n let+ c = Raw_context.remove (pack s i) N.name in\n let s, _ = unpack c in\n s)\n in\n C.project t\n\n let fold s ~order ~init ~f =\n let open Lwt_syntax in\n fold_keys s ~order ~init ~f:(fun i acc ->\n let* result = mem s i in\n match result with 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 Lwt_result_syntax in\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 let*! result = mem c k in\n match result with 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 let open Lwt_result_syntax in\n let* b = Raw_context.get (pack s i) N.name in\n let key () = Raw_context.absolute_key (pack s i) N.name in\n let*? v = of_bytes ~key b in\n return v\n\n let find s i =\n let open Lwt_result_syntax in\n let*! bytes_opt = Raw_context.find (pack s i) N.name in\n match bytes_opt with\n | None -> return_none\n | Some b ->\n let key () = Raw_context.absolute_key (pack s i) N.name in\n let*? v = of_bytes ~key b in\n return_some v\n\n let update s i v =\n let open Lwt_result_syntax in\n let+ c = Raw_context.update (pack s i) N.name (to_bytes v) in\n let s, _ = unpack c in\n C.project s\n\n let init s i v =\n let open Lwt_result_syntax in\n let+ c = Raw_context.init (pack s i) N.name (to_bytes v) in\n let s, _ = unpack c in\n C.project s\n\n let add s i v =\n let open Lwt_syntax in\n let+ c = Raw_context.add (pack s i) N.name (to_bytes v) in\n let s, _ = unpack c in\n C.project s\n\n let add_or_remove s i v =\n let open Lwt_syntax in\n let+ c =\n Raw_context.add_or_remove (pack s i) N.name (Option.map to_bytes v)\n in\n let s, _ = unpack c in\n C.project s\n\n let remove s i =\n let open Lwt_syntax in\n let+ c = Raw_context.remove (pack s i) N.name in\n let s, _ = unpack c in\n C.project s\n\n let remove_existing s i =\n let open Lwt_result_syntax in\n let+ c = Raw_context.remove_existing (pack s i) N.name in\n let s, _ = unpack c in\n C.project s\n\n let clear s =\n let open Lwt_syntax in\n let+ t =\n fold_keys s ~order:`Sorted ~init:s ~f:(fun i s ->\n let+ c = Raw_context.remove (pack s i) N.name in\n let s, _ = unpack c in\n s)\n in\n C.project t\n\n let fold s ~order ~init ~f =\n let open Lwt_syntax in\n fold_keys s ~order ~init ~f:(fun i acc ->\n let* value_opt = get s i in\n match value_opt with Error _ -> 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 let open Lwt_syntax in\n fold_keys s ~order ~init ~f:(fun i acc ->\n let* result = mem s i in\n match result with false -> 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 let open Lwt_result_syntax in\n let* r = Raw_context.Local_context.get local N.name in\n let key () = Raw_context.Local_context.absolute_key local N.name in\n let*? v = of_bytes ~key r in\n return v\n\n let find local =\n let open Lwt_result_syntax in\n let*! bytes_opt = Raw_context.Local_context.find local N.name in\n match bytes_opt with\n | None -> return_none\n | Some b ->\n let key () = Raw_context.Local_context.absolute_key local N.name in\n let*? v = of_bytes ~key b in\n return_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 let open Lwt_result_syntax in\n let*! bytes_opt = Raw_context.find c len_name in\n match bytes_opt with\n | None -> return (0, false)\n | Some len ->\n let*? len = decode_len_value len_name len in\n return (len, true)\n\n let consume_read_gas get c =\n let open Lwt_result_syntax in\n let path_length = List.length (Raw_context.absolute_key c N.name) + 1 in\n let* len = get c len_name in\n let*? read_bytes = decode_len_value len_name len in\n let*? c =\n Raw_context.consume_gas\n c\n (Storage_costs.read_access ~path_length ~read_bytes)\n in\n return c\n\n let consume_write_gas set c v =\n let open Lwt_result_syntax in\n let bytes = to_bytes v in\n let len = Bytes.length bytes in\n let*? c =\n Raw_context.consume_gas\n c\n (Storage_costs.write_access ~written_bytes:len)\n in\n let+ c = set c len_name (encode_len_value bytes) in\n (c, bytes)\n\n let consume_remove_gas del c =\n let open Lwt_result_syntax in\n let*? c =\n Raw_context.consume_gas c (Storage_costs.write_access ~written_bytes:0)\n in\n del c len_name\n\n let mem s i =\n let open Lwt_result_syntax in\n let*? c = consume_mem_gas (pack s i) in\n let*! res = Raw_context.mem c data_name in\n return (Raw_context.project c, res)\n\n let get s i =\n let open Lwt_result_syntax in\n let* c = consume_read_gas Raw_context.get (pack s i) in\n let* b = Raw_context.get c data_name in\n let key () = Raw_context.absolute_key c data_name in\n let*? v = of_bytes ~key b in\n return (Raw_context.project c, v)\n\n let find s i =\n let open Lwt_result_syntax in\n let*? c = consume_mem_gas (pack s i) in\n let s, _ = unpack c in\n let*! exists = Raw_context.mem (pack s i) data_name in\n if exists then\n let+ s, v = get s i in\n (s, Some v)\n else return (C.project s, None)\n\n let update s i v =\n let open Lwt_result_syntax in\n let* prev_size, _ = existing_size (pack s i) in\n let* c, bytes = consume_write_gas Raw_context.update (pack s i) v in\n let+ c = Raw_context.update c data_name bytes in\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 let open Lwt_result_syntax in\n let* c, bytes = consume_write_gas Raw_context.init (pack s i) v in\n let+ c = Raw_context.init c data_name bytes in\n let size = Bytes.length bytes in\n (Raw_context.project c, size)\n\n let add s i v =\n let open Lwt_result_syntax in\n let add c k v =\n let*! ctxt = Raw_context.add c k v in\n return ctxt\n in\n let* prev_size, existed = existing_size (pack s i) in\n let* c, bytes = consume_write_gas add (pack s i) v in\n let+ c = add c data_name bytes in\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 open Lwt_result_syntax in\n let remove c k =\n let*! ctxt = Raw_context.remove c k in\n return ctxt\n in\n let* prev_size, existed = existing_size (pack s i) in\n let* c = consume_remove_gas remove (pack s i) in\n let+ c = remove c data_name in\n (Raw_context.project c, prev_size, existed)\n\n let remove_existing s i =\n let open Lwt_result_syntax in\n let* prev_size, _ = existing_size (pack s i) in\n let* c = consume_remove_gas Raw_context.remove_existing (pack s i) in\n let+ c = Raw_context.remove_existing c data_name in\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 let open Lwt_syntax in\n fold_keys s ~order ~init ~f:(fun i acc ->\n let* result = mem_unaccounted s i in\n match result with false -> return acc | 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 open Lwt_result_syntax 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 let+ _, v = find c k in\n 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 missed_attestations_info = {remaining_slots : int; missed_levels : int}\n\nmodule Slashed_deposits_history : sig\n type slashed_percentage = Percentage.t\n\n type t = (Cycle_repr.t * slashed_percentage) list\n\n (** [add cycle percentage history] adds the [percentage] for the [cycle] in\n the [history].\n If the cycle exists, the associated percentage is updated and capped at\n 100 and the cycle order in the list is unchanged.\n If the cycle does not exist, the new pair [(cycle, percentage)] is added\n at the beginning of the list.\n *)\n val add : Cycle_repr.t -> slashed_percentage -> t -> t\n\n (** [get cycle history] returns the percentage for [cycle] in [history] or\n 0 if there is no such cycle. *)\n val get : Cycle_repr.t -> t -> slashed_percentage\nend\n\n(* TODO #6918: Remove after P *)\nmodule Slashed_deposits_history__Oxford :\n module type of Slashed_deposits_history\n\nmodule Unstake_request : sig\n type request = Cycle_repr.t * Tez_repr.t\n\n type requests = request list\n\n type t = {delegate : Signature.Public_key_hash.t; requests : requests}\n\n val add : Cycle_repr.t -> Tez_repr.t -> requests -> requests tzresult\nend\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 attesting\n opportunity. If it is set, this value is a record of type\n [missed_attestations_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 attesting 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 attesting). *)\n module Missed_attestations :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = missed_attestations_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 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 module Staking_parameters :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Staking_parameters_repr.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 (** Tez that were part of frozen deposits (either [own_frozen] or\n [staked_frozen] in {!Staking_balance}) but have been requested to be\n unstaked by a staker.\n They won't be part of the stake for future distributions.\n For cycles [current_cycle - consensus_rights_delay - max_slashing_period + 1] to\n [current_cycle] they are still slashable.\n For cycle [current_cycle - consensus_rights_delay - max_slashing_period] they are\n not slashable anymore and hence any other older cycles must be squashed\n into this one at cycle end. *)\n module Unstaked_frozen_deposits :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Unstaked_frozen_deposits_repr.t\n and type t := Raw_context.t\n\n (** The contract's unstake requests that haven't been finalized yet. *)\n module Unstake_requests :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Unstake_request.t\n and type t := Raw_context.t\n\n (** The sum of all pseudotokens owned by stakers\n corresponding to shares of the [staked_frozen] in {!Staking_balance}. *)\n module Frozen_deposits_pseudotokens :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Staking_pseudotoken_repr.t\n and type t := Raw_context.t\n\n (** Share of the contract's delegate frozen deposits the contract owns. *)\n module Staking_pseudotokens :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Staking_pseudotoken_repr.t\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 consensus_rights_delay + 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 (* TODO #6918: Remove after P *)\n module Slashed_deposits__Oxford :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Slashed_deposits_history.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\n\n (** Stores the amount of tokens currently present on chain *)\n module Total_supply :\n Single_data_storage with type value = Tez_repr.t 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 + consensus_rights_delay + 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\n(** The pending consensus key of a delegate at the given cycle *)\nmodule Pending_consensus_keys :\n Indexed_data_storage\n with type t := Raw_context.t * Cycle_repr.t\n and type key = Contract_repr.t\n and type value = Signature.public_key\n\n(** All denunciations of the current and previous cycles that will have an effect\n (slashing, reward), i.e. all below 100%, deferred to the end of their\n slashing period. *)\nmodule Pending_denunciations :\n Indexed_data_storage\n with type t := Raw_context.t\n and type key = Signature.public_key_hash\n and type value = Denunciations_repr.t\n\n(** History of slashed deposits: an associative list of cycles to slashed\n percentages.\n\n This storage is inefficient but is not expected to grow large (as of\n 2023-11-28, the last slashing on mainnet dates back to:\n - 2021-12-17 for double baking (154 events in total),\n - 2019-08-08 for double endorsing (24 events in total).\n Since slashings are here grouped by baker and cycle, there would only be\n a few elements in each list.\n\n The slashing percentages are used to compute the real value of stake\n withdrawals.\n Currently there is no limit to the age of the events we need to store\n because there is no such limit for stake withdrawals.\n At worst we can revisit this decision in a later protocol amendment (in\n 25 cycles) or clean up this storage manually or automatically. *)\nmodule Slashed_deposits :\n Indexed_data_storage\n with type t := Raw_context.t\n and type key = Signature.public_key_hash\n and type value = Slashed_deposits_history.t\n\n(** Needed for the stitching from Oxford to P.\n TODO #6957: Remove this from protocol Q. *)\ntype denounced__Oxford = {for_double_attesting : bool; for_double_baking : bool}\n\n(** This type is used to track which denunciations have already been\n recorded, to avoid slashing multiple times the same event. *)\ntype denounced = {\n for_double_preattesting : bool;\n for_double_attesting : bool;\n for_double_baking : bool;\n}\n\n(** {!denounced} with all fields set to [false]. *)\nval default_denounced : denounced\n\n(** Set used to avoid slashing multiple times the same event *)\nmodule Already_denounced :\n Indexed_data_storage\n with type t := Raw_context.t * Cycle_repr.t\n and type key =\n (Raw_level_repr.t * Round_repr.t) * Signature.Public_key_hash.t\n and type value = denounced\n\n(** Needed for the stitching from Oxford to P.\n TODO #6957: Remove this from protocol Q. *)\nmodule Already_denounced__Oxford :\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 = denounced__Oxford\n\nmodule Pending_staking_parameters :\n Indexed_data_storage\n with type t := Raw_context.t * Cycle_repr.t\n and type key = Contract_repr.t\n and type value = Staking_parameters_repr.t\n\nmodule Stake : sig\n (** The map of all the stake of all delegates, including those with\n less than {!Constants_parametric_repr.minimal_stake}. It might\n be large. *)\n module Staking_balance :\n Indexed_data_storage\n with type key = Signature.Public_key_hash.t\n and type value = Full_staking_balance_repr.t\n and type t := Raw_context.t\n\n (** This should be fairly small compared to staking balance *)\n module Active_delegates_with_minimal_stake :\n Data_set_storage\n with type elt = Signature.Public_key_hash.t\n 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 * Stake_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 = Stake_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(** Compounding reward bonus for Adaptive Issuance *)\nmodule Issuance_bonus :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value = Issuance_bonus_repr.t\n and type t := Raw_context.t\n\n(** Multiplicative coefficient for rewards under Adaptive Issuance\n (Includes the bonus) *)\nmodule Issuance_coeff :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value = Q.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 attesting_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\nmodule Adaptive_issuance : sig\n (** Exponential moving average (ema) of votes set in the block header\n protocol_data.contents. Once the feature is activated, it can no\n longer be deactivated without a protocol amendment. **)\n module Launch_ema :\n Single_data_storage with type t := Raw_context.t and type value = Int32.t\n\n (** Cycle [Some c] from which adaptive issuance is (or will be)\n active, or [None] if the feature is not yet planned to activate. **)\n module Activation :\n Single_data_storage\n with type t := Raw_context.t\n and type value = Cycle_repr.t option\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 (** [Attestation_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 attestations. *)\n module Attestation_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 (** [Forbidden_delegates] stores the set of delegates that are not\n allowed to bake or attest blocks. *)\n module Forbidden_delegates :\n Single_data_storage\n with type value = Signature.Public_key_hash.Set.t\n and type t := Raw_context.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 Previous_commitment_period :\n Single_data_storage with type value = int and type t := Raw_context.t\n\n module Parisb2_activation_level :\n Single_data_storage\n with type value = Raw_level_repr.t\n and type t := Raw_context.t\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\n\n (** A carbonated storage for stakers (identified by their public key hashes)\n that are able to stake on commitments. If the storage is\n empty then the rollup is public (anyone can publish commitments for the rollup),\n otherwise it is private (only the members of the whitelist can publish commitments). *)\n module Whitelist :\n Carbonated_data_set_storage\n with type t := Raw_context.t * Sc_rollup_repr.t\n and type elt = Signature.Public_key_hash.t\n\n (** Maximal space available for the whitelist without needing to burn new fees. *)\n module Whitelist_paid_storage_space :\n Indexed_data_storage\n with type key = Sc_rollup_repr.t\n and type value = Z.t\n and type t = Raw_context.t\n\n (** Current storage space in bytes used by the whitelist. *)\n module Whitelist_used_storage_space :\n Indexed_data_storage\n with type t = Raw_context.t\n and type key = Sc_rollup_repr.t\n and type value = Z.t\n\n (** Outbox level and message of the latest whitelist update of a given rollup. *)\n module Last_whitelist_update :\n Non_iterable_indexed_carbonated_data_storage\n with type t = Raw_context.t\n and type key = Sc_rollup_repr.t\n and type value = Sc_rollup_whitelist_repr.last_whitelist_update\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\nmodule Legacy : sig\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" ;
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 Attestation_branch =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"attestation_branch\"]\n end)\n (Branch)\n\n module Forbidden_delegates =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"forbidden_delegates\"]\n end)\n (Signature.Public_key_hash.Set)\nend\n\n(** Contracts handling *)\n\ntype missed_attestations_info = {remaining_slots : int; missed_levels : int}\n\nmodule Missed_attestations_info = struct\n type t = missed_attestations_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\n(* TODO #6918: move closer to its only use left after P *)\nmodule Slashed_deposits_history = struct\n type slashed_percentage = Percentage.t\n\n (* invariant: sorted list *)\n type t = (Cycle_repr.t * slashed_percentage) list\n\n let encoding =\n let open Data_encoding in\n list\n (obj2\n (req \"cycle\" Cycle_repr.encoding)\n (req \"slashed_percentage\" Percentage.encoding))\n\n let add cycle percentage history =\n let rec loop rev_prefix = function\n | (c, p) :: tl when Cycle_repr.(cycle = c) ->\n let p = Percentage.add_bounded p percentage in\n (* cycle found, do not change the order *)\n List.rev_append rev_prefix ((c, p) :: tl)\n | ((c, _) as hd) :: tl when Cycle_repr.(cycle > c) ->\n (* [cycle] must be inserted later *)\n loop (hd :: rev_prefix) tl\n | suffix ->\n (* [cycle] between [rev_prefix] and [suffix] *)\n List.rev_append rev_prefix ((cycle, percentage) :: suffix)\n in\n loop [] history\n\n let rec get cycle = function\n | (c, p) :: _ when Cycle_repr.(cycle = c) -> p\n | (c, _) :: tl when Cycle_repr.(cycle > c) -> get cycle tl\n | _ -> Percentage.p0\nend\n\n(* TODO #6918: Remove after P *)\nmodule Slashed_deposits_history__Oxford = struct\n include Slashed_deposits_history\n\n let encoding =\n let open Data_encoding in\n list\n (obj2\n (req \"cycle\" Cycle_repr.encoding)\n (req \"slashed_percentage\" Percentage.encoding_legacy_in_o))\nend\n\nmodule Unstake_request = struct\n type request = Cycle_repr.t * Tez_repr.t\n\n type requests = request list\n\n type t = {delegate : Signature.Public_key_hash.t; requests : requests}\n\n let request_encoding =\n let open Data_encoding in\n obj2\n (req \"cycle\" Cycle_repr.encoding)\n (req \"requested_amount\" Tez_repr.encoding)\n\n let requests_encoding = Data_encoding.list request_encoding\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {delegate; requests} -> (delegate, requests))\n (fun (delegate, requests) -> {delegate; requests})\n (obj2\n (req \"delegate\" Contract_repr.implicit_encoding)\n (req \"requests\" requests_encoding))\n\n let add cycle amount requests =\n let open Result_syntax in\n let rec loop rev_prefix = function\n | [] ->\n (* cycle does not exist -> add at the head *)\n Ok ((cycle, amount) :: requests)\n | (c, a) :: tl when Cycle_repr.(c = cycle) ->\n let+ a = Tez_repr.(a +? amount) in\n (* cycle found, do not change the order *)\n List.rev_append rev_prefix ((c, a) :: tl)\n | hd :: tl -> loop (hd :: rev_prefix) tl\n in\n loop [] requests\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_attestations =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"missed_attestations\"]\n end)\n (Missed_attestations_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 Staking_parameters =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"staking_parameters\"; \"active\"]\n end)\n (Staking_parameters_repr)\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 let open Lwt_result_syntax in\n let* ctxt, value = I.get ctxt contract in\n let*? ctxt = consume_deserialize_gas ctxt value in\n return (ctxt, value)\n\n let find ctxt contract =\n let open Lwt_result_syntax in\n let* ctxt, value_opt = I.find ctxt contract in\n match value_opt with\n | None -> return (ctxt, None)\n | Some value ->\n let*? ctxt = consume_deserialize_gas ctxt value in\n return (ctxt, value_opt)\n\n let update ctxt contract value =\n let open Lwt_result_syntax in\n let*? ctxt = consume_serialize_gas ctxt value in\n I.update ctxt contract value\n\n let add_or_remove ctxt contract value_opt =\n let open Lwt_result_syntax in\n match value_opt with\n | None -> I.add_or_remove ctxt contract None\n | Some value ->\n let*? ctxt = consume_serialize_gas ctxt value in\n I.add_or_remove ctxt contract value_opt\n\n let init ctxt contract value =\n let open Lwt_result_syntax in\n let*? ctxt = consume_serialize_gas ctxt value in\n I.init ctxt contract value\n\n let add ctxt contract value =\n let open Lwt_result_syntax in\n let*? ctxt = consume_serialize_gas ctxt value in\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 Unstaked_frozen_deposits =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"unstaked_frozen_deposits\"]\n end)\n (Unstaked_frozen_deposits_repr)\n\n module Unstake_requests =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"unstake_requests\"]\n end)\n (Unstake_request)\n\n module Frozen_deposits_pseudotokens =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"frozen_deposits_pseudotokens\"]\n end)\n (Staking_pseudotoken_repr)\n\n module Staking_pseudotokens =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"staking_pseudotokens\"]\n end)\n (Staking_pseudotoken_repr)\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 (* TODO #6918: Remove after P *)\n module Slashed_deposits__Oxford =\n Indexed_context.Make_map\n (Ghost)\n (struct\n let name = [\"slashed_deposits\"]\n end)\n (Slashed_deposits_history__Oxford)\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)\n\n module Total_supply =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"total_supply\"]\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 let open Lwt_result_syntax in\n let* i = Storage.get ctxt in\n let* ctxt = Storage.update ctxt (Lazy_storage_kind.Big_map.Id.next i) in\n return (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 let open Lwt_result_syntax in\n let* ctxt, value = I.get ctxt contract in\n let*? ctxt = consume_deserialize_gas ctxt value in\n return (ctxt, value)\n\n let find ctxt contract =\n let open Lwt_result_syntax in\n let* ctxt, value_opt = I.find ctxt contract in\n match value_opt with\n | None -> return (ctxt, None)\n | Some value ->\n let*? ctxt = consume_deserialize_gas ctxt value in\n return (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 let open Lwt_result_syntax in\n let* i = Storage.get ctxt in\n let* ctxt =\n Storage.update ctxt (Lazy_storage_kind.Sapling_state.Id.next i)\n in\n return (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 let open Lwt_syntax in\n let+ ctx, (_id : id) =\n Indexed_context.Raw_context.remove (ctx, id) [\"commitments\"]\n in\n 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 let open Lwt_syntax in\n let+ ctx, (_id : id) =\n Indexed_context.Raw_context.remove (ctx, id) [\"ciphertexts\"]\n in\n 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 let open Lwt_syntax in\n let* ctx = Nullifiers_size.add (ctx, id) Int64.zero in\n let* ctx, id =\n Indexed_context.Raw_context.remove (ctx, id) [\"nullifiers_ordered\"]\n in\n let+ ctx, (_id : id) =\n Indexed_context.Raw_context.remove (ctx, id) [\"nullifiers_hashed\"]\n in\n 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\nmodule Pending_denunciations =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"denunciations\"]\n end))\n (Public_key_hash_index)\n (Denunciations_repr)\n\nmodule Slashed_deposits =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"slashed_deposits\"]\n end))\n (Public_key_hash_index)\n (Slashed_deposits_history)\n\n(** Per cycle storage *)\n\n(* TODO #6957: Remove this from protocol Q. *)\ntype denounced__Oxford = {for_double_attesting : bool; for_double_baking : bool}\n\ntype denounced = {\n for_double_preattesting : bool;\n for_double_attesting : bool;\n for_double_baking : bool;\n}\n\nlet default_denounced =\n {\n for_double_preattesting = false;\n for_double_attesting = false;\n for_double_baking = false;\n }\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 Already_denounced =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"already_denounced\"]\n end))\n (Pair\n (Pair\n (Make_index\n (Raw_level_repr.Index))\n (Make_index (Round_repr.Index)))\n (Public_key_hash_index))\n (struct\n type t = denounced\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {\n for_double_preattesting;\n for_double_attesting;\n for_double_baking;\n } ->\n (for_double_preattesting, for_double_attesting, for_double_baking))\n (fun ( for_double_preattesting,\n for_double_attesting,\n for_double_baking ) ->\n {for_double_preattesting; for_double_attesting; for_double_baking})\n (obj3\n (req \"for_double_preattesting\" bool)\n (req \"for_double_attesting\" bool)\n (req \"for_double_baking\" bool))\n end)\n\n (* TODO #6957: Remove this from protocol Q. *)\n module Already_denounced__Oxford =\n Make_indexed_data_storage\n (Make_subcontext (Ghost) (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 (struct\n type t = denounced__Oxford\n\n let encoding =\n let open Data_encoding in\n conv\n (fun ({for_double_attesting; for_double_baking} : denounced__Oxford) ->\n (for_double_attesting, for_double_baking))\n (fun (for_double_attesting, for_double_baking) ->\n {for_double_attesting; for_double_baking})\n (obj2\n (req \"for_double_attesting\" bool)\n (req \"for_double_baking\" bool))\n end)\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 * Stake_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\" Stake_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 (Stake_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 module Issuance_bonus =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"issuance_bonus\"]\n end)\n (Issuance_bonus_repr)\n\n module Issuance_coeff =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"issuance_coeff\"]\n end)\n (struct\n type t = Q.t\n\n let encoding =\n Data_encoding.(\n conv_with_guard\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) ->\n if Compare.Z.(num > Z.zero && den > Z.zero) then\n Ok (Q.make num den)\n else\n Error\n \"Invalid Reward Coefficient: only positive values allowed\")\n (obj2 (req \"numerator\" n) (req \"denominator\" n)))\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)\n\n module Pending_consensus_keys =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"pending_consensus_keys\"]\n end))\n (Make_index (Contract_repr.Index))\n (Signature.Public_key)\n\n module Pending_staking_parameters =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"pending_staking_parameters\"]\n end))\n (Make_index (Contract_repr.Index))\n (Staking_parameters_repr)\nend\n\nmodule Already_denounced = Cycle.Already_denounced\nmodule Already_denounced__Oxford = Cycle.Already_denounced__Oxford\nmodule Pending_consensus_keys = Cycle.Pending_consensus_keys\nmodule Pending_staking_parameters = Cycle.Pending_staking_parameters\n\nmodule Stake = struct\n module Staking_balance =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"staking_balance\"]\n end))\n (Public_key_hash_index)\n (Full_staking_balance_repr)\n\n module Active_delegates_with_minimal_stake =\n Make_data_set_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"active_delegates_with_minimal_stake\"]\n end))\n (Public_key_hash_index)\n\n module Selected_distribution_for_cycle = Cycle.Selected_stake_distribution\n module Total_active_stake = Cycle.Total_active_stake\nend\n\nmodule Delegate_sampler_state = Cycle.Delegate_sampler_state\nmodule Issuance_bonus = Cycle.Issuance_bonus\nmodule Issuance_coeff = Cycle.Issuance_coeff\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 let open Lwt_result_syntax in\n let* ctxt = Cycle.Seed.update ctxt cycle seed in\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 attesting_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 attesting_reward_per_slot;\n } ->\n ( baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n attesting_reward_per_slot ))\n (fun ( baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n attesting_reward_per_slot ) ->\n {\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n attesting_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 \"attesting_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 open Lwt_result_syntax in\n let balance_updates ctxt =\n let* balance_updates_opt = Balance_updates.find ctxt in\n match balance_updates_opt with\n | Some balance_updates ->\n let*! ctxt = Balance_updates.remove ctxt in\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 let* operation_results_opt = Operation_results.find ctxt in\n match operation_results_opt with\n | Some operation_results ->\n let*! ctxt = Operation_results.remove ctxt in\n return (ctxt, operation_results)\n | None -> return (ctxt, [])\n in\n let* ctxt, balance_updates = balance_updates ctxt in\n let* ctxt, operation_results = operation_results ctxt in\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 Adaptive_issuance = struct\n module Launch_ema =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"adaptive_issuance_ema\"]\n end)\n (Encoding.Int32)\n\n module Activation =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"adaptive_issuance_launch_cycle\"]\n end)\n (struct\n type t = Cycle_repr.t option\n\n let encoding = Data_encoding.option Cycle_repr.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 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 (* TODO: To be removed in Q, to use [Tenderbake.First_level_of_protocol]\n instead. *)\n module Parisb2_activation_level =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"parisb2_activation_level\"]\n end)\n (Raw_level_repr)\n\n module Previous_commitment_period =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"previous_commitment_period\"]\n end)\n (struct\n type t = int\n\n let encoding = Data_encoding.int31\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)\n\n module Whitelist =\n Make_carbonated_data_set_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"whitelist\"]\n end))\n (Public_key_hash_index)\n\n module Whitelist_paid_storage_space =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"whitelist_paid_bytes\"]\n end)\n (Encoding.Z)\n\n module Whitelist_used_storage_space =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"whitelist_use_bytes\"]\n end)\n (Encoding.Z)\n\n module Last_whitelist_update =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"last_whitelist_update\"]\n end)\n (struct\n type t = Sc_rollup_whitelist_repr.last_whitelist_update\n\n let encoding = Sc_rollup_whitelist_repr.last_whitelist_update_encoding\n end)\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\nmodule Legacy = struct\n module Grand_parent_branch =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"grand_parent_branch\"]\n end)\n (Tenderbake.Branch)\nend\n" ;
} ;
{ name = "Global_constants_costs_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model global_constants_storage/expand_constant_branch *)\n(* fun size -> max 10 (4095. * size) *)\nlet cost_expand_constant_branch size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 4096)\n\n(* model global_constants_storage/expand_no_constant_branch *)\n(* fun size -> max 10 (100. + (4.639474 * (size * (log2 (1 + size))))) *)\nlet cost_expand_no_constant_branch size =\n let size = S.safe_int size in\n let w3 = log2 (size + S.safe_int 1) * size in\n (w3 * S.safe_int 4) + (w3 lsr 1) + (w3 lsr 2) + S.safe_int 100\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(* Copyright (c) 2023 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 Global_constants_costs_generated\nopen S.Syntax\n\n(* generated code is not usable: the model lacks intercept *)\n(* model global_constants_storage/expr_to_address_in_context *)\n(* Approximating 200 + 1.266960 * number of bytes *)\nlet cost_expr_to_address_in_context size =\n let v0 = S.safe_int size in\n S.safe_int 200 + (v0 + (v0 lsr 2))\n\nlet expr_to_address_in_context_cost bytes =\n cost_expr_to_address_in_context (Bytes.length bytes)\n |> Gas_limit_repr.atomic_step_cost\n\nlet expand_constants_branch_cost =\n cost_expand_constant_branch 1 |> Gas_limit_repr.atomic_step_cost\n\nlet expand_no_constants_branch_cost node =\n cost_expand_no_constant_branch (Script_repr.micheline_nodes node)\n |> Gas_limit_repr.atomic_step_cost\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\n(* No model is given. The original definition was a copy of\n Global_constants_costs.expr_to_address_in_context_cost.\n*)\nlet hash_bytes_cost = Global_constants_costs.expr_to_address_in_context_cost\n\nlet hash_of_node ctxt node =\n let open Result_syntax in\n let* ctxt =\n Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node)\n in\n let node = Micheline.strip_locations node in\n let* bytes =\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 in\n let+ ctxt = Raw_context.consume_gas ctxt (hash_bytes_cost bytes) in\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 open Result_syntax in\n let node = Micheline.strip_locations node in\n let+ bytes =\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 in\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 consensus_rights_delay : Raw_context.t -> int\n\nval blocks_preservation_cycles : Raw_context.t -> int\n\nval delegate_parameters_activation_delay : 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 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 minimal_frozen_stake : Raw_context.t -> Tez_repr.t\n\nval vdf_difficulty : Raw_context.t -> int64\n\nval origination_size : Raw_context.t -> int\n\nval issuance_weights :\n Raw_context.t -> Constants_parametric_repr.issuance_weights\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_toggle_ema_threshold : Raw_context.t -> int32\n\nval parametric : Raw_context.t -> Constants_parametric_repr.t\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 limit_of_delegation_over_baking : Raw_context.t -> int\n\nval percentage_of_frozen_deposits_slashed_per_double_baking :\n Raw_context.t -> Percentage.t\n\nval percentage_of_frozen_deposits_slashed_per_double_attestation :\n Raw_context.t -> Percentage.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_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 sc_rollup_riscv_pvm_enable : Raw_context.t -> bool\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 sc_rollup_reveal_activation_level :\n Raw_context.t -> Constants_parametric_repr.sc_rollup_reveal_activation_level\n\nval sc_rollup_private_enable : Raw_context.t -> bool\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\nval zk_rollup_max_ticket_payload_size : Raw_context.t -> int\n\nval adaptive_issuance_enable : Raw_context.t -> bool\n\nval adaptive_issuance_global_limit_of_staking_over_baking : Raw_context.t -> int\n\nval adaptive_issuance_edge_of_staking_over_delegation : Raw_context.t -> int\n\nval adaptive_issuance_launch_ema_threshold : Raw_context.t -> int32\n\nval adaptive_issuance_activation_vote_enable : Raw_context.t -> bool\n\nval adaptive_issuance_rewards_params :\n Raw_context.t -> Constants_parametric_repr.adaptive_rewards_params\n\nval adaptive_issuance_autostaking_enable : Raw_context.t -> bool\n\nval adaptive_issuance_force_activation : Raw_context.t -> bool\n\nval adaptive_issuance_ns_enable : Raw_context.t -> bool\n\nval direct_ticket_spending_enable : Raw_context.t -> bool\n\n(** The following accessors are not actual parameters, but constants that\n derive from the protocol parameter. *)\n\n(** Delay, in cycles, before the current state of the stake impacts the\n issuance rate.*)\nval issuance_modification_delay : Raw_context.t -> int\n\n(** Delay, in cycles, before activation of AI after the voting EMA threshold is\n reached *)\nval adaptive_issuance_activation_delay : Raw_context.t -> int\n\n(** Tolerated period of inactivity, in cycles, before a delegate is\n deactivated *)\nval tolerated_inactivity_period : Raw_context.t -> int\n\n(** Delay before the activation of a consensus key, in cycles *)\nval consensus_key_activation_delay : Raw_context.t -> int\n\n(** Number of cycles during which a misbehavior of a delegate will induce a\n slashing of the funds that are currently in its frozen deposit. *)\n\nval slashable_deposits_period : 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 consensus_rights_delay c =\n let constants = Raw_context.constants c in\n constants.consensus_rights_delay\n\nlet blocks_preservation_cycles c =\n let constants = Raw_context.constants c in\n constants.blocks_preservation_cycles\n\nlet delegate_parameters_activation_delay c =\n let constants = Raw_context.constants c in\n constants.delegate_parameters_activation_delay\n\n(** Issuance modification delay:\n number of cycles after which the issuance rate -- computed from current stake\n over total supply -- will be used.\n\n We use consensus_rights_delay so that the issuance rate in one cycle\n corresponds to the \"active\" staking rights.\n*)\nlet issuance_modification_delay c =\n let constants = Raw_context.constants c in\n constants.consensus_rights_delay\n\n(** Adaptive Issuance activation delay:\n After the e.m.a. of AI votes reaches the threshold, we wait for this delay\n before effectively activating AI.\n*)\nlet adaptive_issuance_activation_delay c =\n let constants = Raw_context.constants c in\n 1 + constants.consensus_rights_delay + Constants_repr.max_slashing_period\n\n(** Tolerated inactivity period for delegates before being deactivated. *)\nlet tolerated_inactivity_period c =\n let constants = Raw_context.constants c in\n 1 + constants.consensus_rights_delay\n\n(** Delay between consensus key declaration by the delegate and the cycle where\n it has to be used to sign on behalf of the delegate. *)\nlet consensus_key_activation_delay c =\n let constants = Raw_context.constants c in\n constants.consensus_rights_delay\n\n(** Number of cycles during which a misbehavior of the delegate will induce a\n slashing of the funds that are currently in its frozen deposits. *)\nlet slashable_deposits_period c =\n let constants = Raw_context.constants c in\n constants.consensus_rights_delay\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 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 minimal_frozen_stake c =\n let constants = Raw_context.constants c in\n constants.minimal_frozen_stake\n\nlet vdf_difficulty c =\n let constants = Raw_context.constants c in\n constants.vdf_difficulty\n\nlet origination_size c =\n let constants = Raw_context.constants c in\n constants.origination_size\n\nlet issuance_weights c =\n let constants = Raw_context.constants c in\n constants.issuance_weights\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_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 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 limit_of_delegation_over_baking c =\n let constants = Raw_context.constants c in\n constants.limit_of_delegation_over_baking\n\nlet percentage_of_frozen_deposits_slashed_per_double_baking c =\n let constants = Raw_context.constants c in\n constants.percentage_of_frozen_deposits_slashed_per_double_baking\n\nlet percentage_of_frozen_deposits_slashed_per_double_attestation c =\n let constants = Raw_context.constants c in\n constants.percentage_of_frozen_deposits_slashed_per_double_attestation\n\nlet testnet_dictator c =\n let constants = Raw_context.constants c in\n constants.testnet_dictator\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 sc_rollup_reveal_activation_level c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.reveal_activation_level\n\nlet sc_rollup_private_enable c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.private_enable\n\nlet sc_rollup_riscv_pvm_enable c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.riscv_pvm_enable\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\nlet zk_rollup_max_ticket_payload_size c =\n let zk_rollup = Raw_context.zk_rollup c in\n zk_rollup.max_ticket_payload_size\n\nlet adaptive_issuance c = (Raw_context.constants c).adaptive_issuance\n\nlet adaptive_issuance_enable c = Raw_context.adaptive_issuance_enable c\n\nlet adaptive_issuance_global_limit_of_staking_over_baking c =\n (adaptive_issuance c).global_limit_of_staking_over_baking\n\nlet adaptive_issuance_edge_of_staking_over_delegation c =\n (adaptive_issuance c).edge_of_staking_over_delegation\n\nlet adaptive_issuance_launch_ema_threshold c =\n (adaptive_issuance c).launch_ema_threshold\n\nlet adaptive_issuance_rewards_params c =\n (adaptive_issuance c).adaptive_rewards_params\n\nlet adaptive_issuance_activation_vote_enable c =\n (adaptive_issuance c).activation_vote_enable\n\nlet adaptive_issuance_autostaking_enable c =\n (adaptive_issuance c).autostaking_enable\n\nlet adaptive_issuance_force_activation c =\n (adaptive_issuance c).force_activation\n\nlet adaptive_issuance_ns_enable c = (adaptive_issuance c).ns_enable\n\nlet direct_ticket_spending_enable c =\n (Raw_context.constants c).direct_ticket_spending_enable\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\n(** When the given level is two or above, return its predecessor. When\n the given level is one or less, return [None] (because we cannot\n build the [Level_repr.t] for level zero). *)\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_preserved_block_level : Raw_context.t -> Raw_level_repr.t\n\nval last_finalized_block_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 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 (* This returns [None] rather than level zero when [l] is level one\n because {!from_raw} raises an exception when called on zero\n (because [Level_repr.era_of_level] cannot find level zero's era). *)\n match Raw_level_repr.pred_dontreturnzero 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_preserved_block_level c =\n let level = Raw_context.current_level c in\n let block_conservation_cycles =\n Constants_storage.blocks_preservation_cycles c\n in\n match Cycle_repr.sub level.cycle block_conservation_cycles with\n | None -> Raw_level_repr.root\n | Some cycle -> (first_level_in_cycle c cycle).level\n\nlet last_finalized_block_level c =\n let current = Raw_context.current_level c in\n let current_raw = current.level in\n let finalized_level = Raw_level_repr.sub current_raw 2 in\n match finalized_level with None -> Raw_level_repr.root | Some l -> l\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_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 open Lwt_result_syntax in\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 let* status = Storage.Seed.Nonce.get ctxt level in\n match status with\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 let open Lwt_result_syntax in\n let* unrevealed = get_unrevealed ctxt level in\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 let open Lwt_result_syntax in\n let+ status_opt = Storage.Seed.Nonce.find ctxt level in\n match status_opt with\n | None -> No_nonce_expected\n | Some status -> 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 [consensus_rights_delay+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 attesting\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\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 open Lwt_result_syntax in\n let levels = Level_storage.levels_with_commitments_in_cycle ctxt cycle in\n let combine (c, unrevealed) level =\n let* seed = Storage.Seed.Nonce.get c level in\n match seed with\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 open Lwt_result_syntax in\n let current_cycle = (Level_storage.current ctxt).cycle in\n let delay = Constants_storage.consensus_rights_delay ctxt in\n let cycle_computed = Cycle_repr.add current_cycle (delay + 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 let* seed = Storage.Seed.Nonce.get c level in\n match seed with\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 open Lwt_result_syntax in\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 delay = Constants_storage.consensus_rights_delay ctxt in\n let cycle_computed = Cycle_repr.add current_cycle (delay + 1) in\n let previous_cycle = Cycle_repr.add current_cycle delay 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 open Lwt_result_syntax in\n let* r = get_seed_computation_status ctxt in\n match r with\n | Computation_finished -> tzfail Already_accepted\n | Nonce_revelation_stage -> tzfail Too_early_revelation\n | Vdf_revelation_stage {seed_discriminant; seed_challenge} ->\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_unit\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 delay = Constants_storage.consensus_rights_delay ctxt in\n let cycle_computed = Cycle_repr.add current_cycle (delay + 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 open Lwt_result_syntax in\n let delay = Constants_storage.consensus_rights_delay ctxt in\n let max_slashing_period = Constants_repr.max_slashing_period 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 (delay + 1)\n else Cycle_repr.add current_cycle delay\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 open Lwt_result_syntax in\n let delay = Constants_storage.consensus_rights_delay ctxt in\n let* ctxt = Storage.Seed_status.init ctxt Seed_repr.RANDAO_seed in\n let+ (_ : int), ctxt =\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 (delay + 2))\n in\n ctxt\n\nlet cycle_end ctxt last_cycle =\n let open Lwt_result_syntax in\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 open Lwt_result_syntax in\n let contract = Contract_repr.Implicit manager in\n let* key_opt = Storage.Contract.Manager.find c contract in\n match key_opt with\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 open Lwt_result_syntax in\n let contract = Contract_repr.Implicit manager in\n let* key_opt = Storage.Contract.Manager.get c contract in\n match key_opt with\n | Public_key _ -> tzfail (Previously_revealed_key contract)\n | Hash expected_hash ->\n (* Ensure that the manager is equal to the retrieved hash. *)\n let*? () =\n error_unless\n (Signature.Public_key_hash.equal manager expected_hash)\n (Inconsistent_hash\n {public_key; expected_hash; provided_hash = manager})\n in\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 let* () =\n when_ check_consistency (fun () ->\n Lwt.return @@ check_public_key public_key expected_hash)\n in\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 open Lwt_result_syntax in\n let contract = Contract_repr.Implicit pkh in\n let* key_opt = Storage.Contract.Manager.find ctxt contract in\n match key_opt with\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 let open Lwt_result_syntax in\n let*! inactive =\n Storage.Contract.Inactive_delegate.mem\n ctxt\n (Contract_repr.Implicit delegate)\n in\n if inactive then Lwt.return_ok inactive\n else\n let+ cycle_opt =\n Storage.Contract.Delegate_last_cycle_before_deactivation.find\n ctxt\n (Contract_repr.Implicit delegate)\n in\n match cycle_opt with\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 let open Lwt_result_syntax in\n let* inactive = is_inactive ctxt delegate in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let tolerance = Constants_storage.tolerated_inactivity_period ctxt in\n let consensus_rights_delay = Constants_storage.consensus_rights_delay 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 `tolerance` cycles\n after the current cycle before to be deactivated.\n - if the delegate is new or inactive, we give it additionally\n `consensus_rights_delay` because the delegate needs this number of cycles to\n receive rights, so `tolerance + consensus_rights_delay` in total. *)\n let delegate_contract = Contract_repr.Implicit delegate in\n let* current_last_active_cycle =\n Storage.Contract.Delegate_last_cycle_before_deactivation.find\n ctxt\n delegate_contract\n in\n let last_active_cycle =\n match current_last_active_cycle with\n | None -> Cycle_repr.add current_cycle (tolerance + consensus_rights_delay)\n | Some current_last_active_cycle ->\n let delay =\n if inactive then tolerance + consensus_rights_delay else tolerance\n in\n let updated = Cycle_repr.add current_cycle delay in\n Cycle_repr.max current_last_active_cycle updated\n in\n let*! ctxt =\n Storage.Contract.Delegate_last_cycle_before_deactivation.add\n ctxt\n delegate_contract\n last_active_cycle\n in\n if not inactive then return (ctxt, inactive)\n else\n let*! ctxt =\n Storage.Contract.Inactive_delegate.remove ctxt delegate_contract\n in\n return (ctxt, inactive)\n" ;
} ;
{ name = "Sapling_storage_costs_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model sapling/SAPLING_APPLY_DIFF *)\n(* fun size1 ->\n fun size2 -> max 10 ((1300000. + (5000. * size1)) + (55000. * size2)) *)\nlet cost_SAPLING_APPLY_DIFF size1 size2 =\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n (size1 * S.safe_int 5120) + (size2 * S.safe_int 55296) + S.safe_int 1300000\n" ;
} ;
{ name = "Sapling_storage_costs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2023 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 Sapling_storage_costs_generated\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 let open Lwt_result_syntax in\n assert_node node height ;\n assert_height height ;\n let+ ctx, cm_opt = Storage.Sapling.Commitments.find (ctx, id) node in\n match cm_opt with\n | None ->\n let hash = H.uncommitted ~height in\n (ctx, hash)\n | 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 let open Lwt_result_syntax in\n assert_node node height ;\n assert_height height ;\n assert_pos pos height ;\n match (height, cms) with\n | _, [] ->\n let+ ctx, h = get_root_height ctx id node height in\n (ctx, 0, h)\n | 0, [cm] ->\n let h = H.of_commitment cm in\n let+ ctx, size = Storage.Sapling.Commitments.init (ctx, id) node h in\n (ctx, size, h)\n | _ ->\n let height = height - 1 in\n let* ctx, size_children, hl, hr =\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 let* ctx, size_l, hl = insert ctx id (left node) height pos cml in\n let+ ctx, size_r, hr = insert ctx id (right node) height 0L cmr in\n (ctx, size_l + size_r, hl, hr)\n else\n let* ctx, hl = get_root_height ctx id (left node) height in\n let pos = Int64.(sub pos (pow2 height)) in\n let+ ctx, size_r, hr = insert ctx id (right node) height pos cms in\n (ctx, size_r, hl, hr)\n in\n let h = H.merkle_hash ~height hl hr in\n let+ ctx, size, _existing =\n Storage.Sapling.Commitments.add (ctx, id) node h\n in\n (ctx, size + size_children, h)\n\n let rec fold_from_height ctx id node ~pos ~f ~acc height =\n let open Lwt_result_syntax in\n assert_node node height ;\n assert_height height ;\n assert_pos pos height ;\n let* _ctx, cm_opt =\n Storage.Sapling.Commitments.find (ctx, id) node\n (* we don't count gas for this function, it is called only by RPC *)\n in\n match cm_opt with\n | None -> return acc\n | 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 let* acc =\n fold_from_height ctx id (left node) ~pos ~f ~acc (height - 1)\n in\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 open Lwt_result_syntax in\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 let+ ctx, size, _h = insert ctx id root_node max_height pos cms in\n (ctx, size)\n\n let get_from ctx id pos =\n let open Lwt_result_syntax in\n let+ l =\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 in\n 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 open Lwt_result_syntax in\n let rec aux (ctx, acc) pos =\n let* ctx, c = Storage.Sapling.Ciphertexts.find (ctx, id) pos in\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 let add ctx id nfs =\n let open Lwt_result_syntax in\n let* nf_start_pos = size ctx id in\n let* ctx, nf_end_pos, size =\n List.fold_left_es\n (fun (ctx, pos, acc_size) nf ->\n let* ctx, size =\n Storage.Sapling.Nullifiers_hashed.init (ctx, id) nf\n in\n let+ ctx = Storage.Sapling.Nullifiers_ordered.init (ctx, id) pos nf in\n (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size)))\n (ctx, nf_start_pos, Z.zero)\n (List.rev nfs)\n in\n let+ ctx = Storage.Sapling.Nullifiers_size.update (ctx, id) nf_end_pos in\n (ctx, size)\n\n let get_from ctx id offset =\n let open Lwt_result_syntax in\n let rec aux acc pos =\n let* nf_opt = Storage.Sapling.Nullifiers_ordered.find (ctx, id) pos in\n match nf_opt with\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 let open Lwt_result_syntax in\n let* pos = Storage.Sapling.Roots_pos.get (ctx, id) in\n Storage.Sapling.Roots.get (ctx, id) pos\n\n let init ctx id =\n let open Lwt_result_syntax in\n let rec aux ctx pos =\n if Compare.Int32.(pos < 0l) then return ctx\n else\n let* ctx =\n Storage.Sapling.Roots.init (ctx, id) pos Commitments.default_root\n in\n aux ctx (Int32.pred pos)\n in\n let* ctx = aux ctx (Int32.pred size) in\n let* ctx = Storage.Sapling.Roots_pos.init (ctx, id) 0l in\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 let open Lwt_result_syntax in\n let* start_pos = Storage.Sapling.Roots_pos.get (ctx, id) in\n let rec aux pos =\n let* hash = Storage.Sapling.Roots.get (ctx, id) pos in\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 let open Lwt_result_syntax in\n let* pos = Storage.Sapling.Roots_pos.get (ctx, id) in\n let level = (Raw_context.current_level ctx).level in\n let* stored_level = Storage.Sapling.Roots_level.get (ctx, id) in\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 let*! ctx = Storage.Sapling.Roots.add (ctx, id) pos root in\n return ctx\n else\n (* it's the first add for this level *)\n (* TODO(samoht): why is it using [update] and not [init] then? *)\n let* ctx = Storage.Sapling.Roots_level.update (ctx, id) level in\n let pos = Int32.rem (Int32.succ pos) size in\n let* ctx = Storage.Sapling.Roots_pos.update (ctx, id) pos in\n let*! ctx = Storage.Sapling.Roots.add (ctx, id) pos root in\n return ctx\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 let open Lwt_result_syntax in\n let+ memo_size = Storage.Sapling.Memo_size.get (ctxt, id) in\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 let open Lwt_result_syntax in\n let*! ctx = Storage.Sapling.Memo_size.add (ctx, id) memo_size in\n let*! ctx = Storage.Sapling.Commitments_size.add (ctx, id) Int64.zero in\n let*! ctx = Commitments.init ctx id in\n let*! ctx = Nullifiers.init ctx id in\n let* ctx = Roots.init ctx id in\n let*! ctx = Ciphertexts.init ctx id in\n return ctx\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 Lwt_result_syntax in\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_storage_costs.cost_SAPLING_APPLY_DIFF nb_nullifiers nb_commitments\n in\n let*? ctx = Raw_context.consume_gas ctx sapling_cost in\n let* cm_start_pos = Storage.Sapling.Commitments_size.get (ctx, id) in\n let cms = List.rev_map fst diff.commitments_and_ciphertexts in\n let* ctx, size = Commitments.add ctx id cms cm_start_pos in\n let* ctx =\n Storage.Sapling.Commitments_size.update\n (ctx, id)\n (Int64.add cm_start_pos (Int64.of_int nb_commitments))\n in\n let* ctx, _ct_end_pos, size =\n List.fold_left_es\n (fun (ctx, pos, acc_size) (_cm, cp) ->\n let+ ctx, size = Ciphertexts.add ctx id cp pos in\n (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size)))\n (ctx, cm_start_pos, Z.of_int size)\n (List.rev diff.commitments_and_ciphertexts)\n in\n let* ctx, size_nf = Nullifiers.add ctx id diff.nullifiers in\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 let* ctx, root = Commitments.get_root ctx id in\n let+ ctx = Roots.add ctx id root in\n (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 let open Lwt_result_syntax in\n if\n not\n Sapling.Commitment.(\n valid_position offset_commitment && valid_position offset_nullifier)\n then failwith \"Invalid argument.\"\n else\n let* commitments = Commitments.get_from ctx id offset_commitment in\n let* root = Roots.get ctx id in\n let* nullifiers = Nullifiers.get_from ctx id offset_nullifier in\n let+ _ctx, ciphertexts =\n Ciphertexts.get_from ctx id offset_commitment\n (* we don't count gas for RPCs *)\n in\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(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2020 Nomadic Labs, <contact@nomadic-labs.com> *)\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(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2020 Nomadic Labs, <contact@nomadic-labs.com> *)\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 open Lwt_result_syntax in\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 let* ctxt = Storage.Big_map.Key_type.init ctxt id key_type in\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 let open Lwt_result_syntax in\n match value with\n | None ->\n let+ ctxt, freed, existed =\n Storage.Big_map.Contents.remove (ctxt, id) key_hash\n in\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 let+ ctxt, size_diff, existed =\n Storage.Big_map.Contents.add (ctxt, id) key_hash v\n in\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 let open Lwt_result_syntax in\n List.fold_left_es\n (fun (ctxt, size) update ->\n let+ ctxt, added_size = apply_update ctxt ~id update in\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 let open Lwt_result_syntax in\n fun ctxt (module OPS) ~id updates ->\n let* ctxt, updates_size = OPS.apply_updates ctxt ~id updates in\n if Z.(equal updates_size zero) then return (ctxt, updates_size)\n else\n let* size = OPS.Total_bytes.get ctxt id in\n let+ ctxt = OPS.Total_bytes.update ctxt id (Z.add size updates_size) in\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 let open Lwt_result_syntax in\n fun ctxt (module OPS) ~id init ->\n match init with\n | Existing -> return (ctxt, Z.zero)\n | Copy {src} ->\n let* ctxt = OPS.copy ctxt ~from:src ~to_:id in\n if OPS.Id.is_temp id then return (ctxt, Z.zero)\n else\n let+ copy_size = OPS.Total_bytes.get ctxt src in\n (ctxt, Z.add copy_size OPS.bytes_size_for_empty)\n | Alloc alloc ->\n let* ctxt = OPS.Total_bytes.init ctxt id Z.zero in\n let+ ctxt = OPS.alloc ctxt ~id alloc in\n (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 let open Lwt_result_syntax in\n fun ctxt ((module OPS) as ops) ~id diff ->\n match diff with\n | Remove ->\n if OPS.Id.is_temp id then\n let*! ctxt = OPS.remove ctxt id in\n return (ctxt, Z.zero)\n else\n let* size = OPS.Total_bytes.get ctxt id in\n let*! ctxt = OPS.remove ctxt id in\n return (ctxt, Z.neg (Z.add size OPS.bytes_size_for_empty))\n | Update {init; updates} ->\n let* ctxt, init_size = apply_init ctxt ops ~id init in\n let* ctxt, updates_size = apply_updates ctxt ops ~id updates in\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 let open Lwt_result_syntax in\n List.fold_left_es\n (fun (ctxt, total_size) (Item (k, id, diff)) ->\n let ops = get_ops k in\n let+ ctxt, added_size = apply_diff ctxt ops ~id diff in\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 let open Lwt_syntax in\n Raw_context.map_temporary_lazy_storage_ids_s ctxt (fun temp_ids ->\n let+ ctxt =\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 in\n (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\nval fold :\n Raw_context.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Blinded_public_key_hash.t -> Tez_repr.t -> 'a -> 'a Lwt.t) ->\n 'a 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 let open Lwt_result_syntax in\n let+ balance = Storage.Commitments.find ctxt bpkh in\n Option.value ~default:Tez_repr.zero balance\n\nlet increase_commitment_only_call_from_token ctxt bpkh amount =\n let open Lwt_result_syntax in\n if Tez_repr.(amount = zero) then return ctxt\n else\n let* balance = committed_amount ctxt bpkh in\n let*? new_balance = Tez_repr.(amount +? balance) in\n let*! result = Storage.Commitments.add ctxt bpkh new_balance in\n return result\n\nlet decrease_commitment_only_call_from_token ctxt bpkh amount =\n let open Lwt_result_syntax in\n let* balance = committed_amount ctxt bpkh in\n let*? new_balance = Tez_repr.(balance -? amount) in\n let*! result =\n if Tez_repr.(new_balance = Tez_repr.zero) then\n Storage.Commitments.remove ctxt bpkh\n else Storage.Commitments.add ctxt bpkh new_balance\n in\n return result\n\nlet fold c = Storage.Commitments.fold c\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 let open Lwt_result_syntax in\n let* ctxt = init ctxt @@ Voting_period_repr.root ~start_position in\n Storage.Vote.Pred_period_kind.init ctxt Voting_period_repr.Proposal\n\nlet common ctxt =\n let open Lwt_result_syntax in\n let* current_period = get_current ctxt in\n let+ ctxt = Storage.Vote.Pred_period_kind.update ctxt current_period.kind in\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 let open Lwt_result_syntax in\n let* ctxt, current_period, start_position = common ctxt in\n Voting_period_repr.raw_reset current_period ~start_position\n |> set_current ctxt\n\nlet succ ctxt =\n let open Lwt_result_syntax in\n let* ctxt, current_period, start_position = common ctxt in\n Voting_period_repr.raw_succ current_period ~start_position |> set_current ctxt\n\nlet get_current_kind ctxt =\n let open Lwt_result_syntax in\n let+ {kind; _} = get_current ctxt in\n kind\n\nlet get_current_info ctxt =\n let open Lwt_result_syntax in\n let+ voting_period = get_current ctxt in\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 let open Lwt_result_syntax in\n let+ voting_period = get_current ctxt in\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 let open Lwt_result_syntax in\n let+ remaining = get_current_remaining ctxt in\n Compare.Int32.(remaining = 0l)\n\nlet blocks_before_activation ctxt =\n let open Lwt_result_syntax in\n let* voting_period = get_current ctxt in\n match voting_period with\n | Voting_period_repr.{kind = Adoption; _} ->\n let* result = get_current_remaining ctxt in\n return_some result\n | _ -> return_none\n\nlet get_rpc_current_info ctxt =\n let open Lwt_result_syntax in\n let* ({voting_period; position; _} as voting_period_info) =\n get_current_info ctxt\n in\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 let+ pred_kind = Storage.Vote.Pred_period_kind.get ctxt in\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 let open Lwt_result_syntax in\n let*? level =\n Level_storage.from_raw_with_offset\n ctxt\n ~offset:1l\n (Level_storage.current ctxt).level\n in\n let+ voting_period = get_current ctxt in\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 let open Lwt_result_syntax in\n let*? () =\n error_when\n Chain_id.(chain_id = Constants_repr.mainnet_id)\n Forbidden_on_mainnet\n in\n let* current_period = get_current ctxt in\n let new_period = {current_period with kind} in\n set_current ctxt new_period\nend\n" ;
} ;
{ name = "Cache_repr_costs_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model cache/CACHE_UPDATE *)\n(* fun size -> max 10 (600. + (43. * (log2 (1 + size)))) *)\nlet cost_CACHE_UPDATE size =\n let size = S.safe_int size in\n (log2 (size + S.safe_int 1) * S.safe_int 43) + S.safe_int 600\n" ;
} ;
{ name = "Cache_repr_costs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2023 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 Cache_repr_costs_generated\n\nlet cache_update_cost size =\n cost_CACHE_UPDATE size |> Gas_limit_repr.atomic_step_cost\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 (* 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 bytes / minimal_size_of_typed_contract_in_bytes\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 Cache_repr_costs.cache_update_cost 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 open Lwt_result_syntax in\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 let* block_opt =\n match blocks_before_activation with\n | None -> Voting_period_storage.blocks_before_activation ctxt\n | Some block -> return_some block\n in\n match block_opt with\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 let open Lwt_result_syntax in\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 let* v = C.value_of_identifier ctxt i in\n 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 open Result_syntax in\n let cache_size_in_bytes = size ctxt in\n let+ ctxt =\n Raw_context.consume_gas\n ctxt\n (Cache_costs.cache_update ~cache_size_in_bytes)\n in\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 let*? ctxt =\n Raw_context.consume_gas\n ctxt\n (Cache_costs.cache_find ~cache_size_in_bytes)\n in\n let*! value_opt = Admin.find ctxt (mk ~id) in\n match value_opt with\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 Result_syntax.tzfail @@ Zk_rollup_invalid_op_code op.op_code\n else Result_syntax.return_unit)\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 Result_syntax in\n let open Zk_rollup_repr in\n function\n | Empty _ -> tzfail Zk_rollup_pending_list_too_short\n | Pending {next_index; length} ->\n 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 = "Stake_context" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 on stake and depending on the context. *)\n\n(** Apply the delegation_over_baking and staking_over_baking limits of\n a delegate. Overstaked tez count as delegated, overdelegated tez\n do not count at all. *)\nval apply_limits :\n Raw_context.t ->\n Staking_parameters_repr.t ->\n Full_staking_balance_repr.t ->\n Stake_repr.t tzresult\n\n(** The weight of a baker used for baking and attesting rights. *)\nval baking_weight :\n Raw_context.t ->\n Staking_parameters_repr.t ->\n Full_staking_balance_repr.t ->\n int64 tzresult\n\nval optimal_frozen_wrt_delegated_without_ai :\n Raw_context.t -> Full_staking_balance_repr.t -> Tez_repr.t tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 apply_limits ctxt staking_parameters staking_balance =\n let open Result_syntax in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let own_frozen = Full_staking_balance_repr.own_frozen staking_balance in\n let staked_frozen = Full_staking_balance_repr.staked_frozen staking_balance in\n let allowed_staked_frozen =\n Full_staking_balance_repr.allowed_staked_frozen\n ~adaptive_issuance_global_limit_of_staking_over_baking:\n (Constants_storage.adaptive_issuance_global_limit_of_staking_over_baking\n ctxt)\n ~delegate_limit_of_staking_over_baking_millionth:\n staking_parameters\n .Staking_parameters_repr.limit_of_staking_over_baking_millionth\n staking_balance\n in\n let delegated =\n Full_staking_balance_repr.min_delegated_in_cycle\n ~current_cycle\n staking_balance\n in\n let limit_of_delegation_over_baking =\n Int64.of_int (Constants_storage.limit_of_delegation_over_baking ctxt)\n in\n (* Overstaked tez count as delegated.\n Note that, unlike delegated tez, overstaked tez may not have been staked\n the whole cycle to contribute to rights, but they are going to be frozen\n for several cycles. *)\n let* overstaked = Tez_repr.(staked_frozen -? allowed_staked_frozen) in\n let* delegated = Tez_repr.(delegated +? overstaked) in\n (* Overdelegated tez don't count. *)\n let delegated =\n match Tez_repr.(own_frozen *? limit_of_delegation_over_baking) with\n | Ok max_allowed_delegated -> Tez_repr.min max_allowed_delegated delegated\n | Error _max_allowed_delegated_overflows -> delegated\n in\n let* weighted_delegated =\n if Constants_storage.adaptive_issuance_enable ctxt then\n let edge_of_staking_over_delegation =\n Int64.of_int\n (Constants_storage.adaptive_issuance_edge_of_staking_over_delegation\n ctxt)\n in\n Tez_repr.(delegated /? edge_of_staking_over_delegation)\n else return delegated\n in\n let+ frozen = Tez_repr.(own_frozen +? allowed_staked_frozen) in\n Stake_repr.make ~frozen ~weighted_delegated\n\nlet optimal_frozen_wrt_delegated_without_ai ctxt full_staking_balance =\n let open Result_syntax in\n let limit_of_delegation_over_baking =\n Int64.of_int (Constants_storage.limit_of_delegation_over_baking ctxt)\n in\n (* Without AI, frozen deposit is optimal when `delegated =\n limit_of_delegation_over_baking * frozen`. Freezing more would\n unnecessarily freeze tokens, freezing less would under exploit delegated\n rights due to over-delegation limit.\n\n With AI the optimum is to freeze as much as possible, this computation\n would make no sense. *)\n let delegated =\n Full_staking_balance_repr.current_delegated full_staking_balance\n in\n let own_frozen = Full_staking_balance_repr.own_frozen full_staking_balance in\n let* power = Tez_repr.(delegated +? own_frozen) in\n let* opti_frozen =\n Tez_repr.mul_ratio\n ~rounding:`Up\n power\n ~num:1L\n ~den:(Int64.add limit_of_delegation_over_baking 1L)\n in\n let min_frozen = Constants_storage.minimal_frozen_stake ctxt in\n return (Tez_repr.max opti_frozen min_frozen)\n\nlet baking_weight ctxt staking_parameters f =\n let open Result_syntax in\n let+ s = apply_limits ctxt staking_parameters f in\n Stake_repr.staking_weight s\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(** [is_delegate ctxt pkh] returns whether [pkh] is a delegate. *)\nval is_delegate :\n Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t\n\n(** [delegate_status] describes whether an implicit account is a delegate, or if\n it has a delegate (i.e. other than itself), or has no delegate. *)\ntype delegate_status =\n | Delegate\n | Delegated of Signature.Public_key_hash.t\n | Undelegated\n\n(** [get_delegate_status ctxt pkh] returns the delegation status associated to\n [pkh]. *)\nval get_delegate_status :\n Raw_context.t -> Signature.Public_key_hash.t -> delegate_status 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 =\n let open Result_syntax in\n function\n | Bls tz4 -> tzfail (Forbidden_tz4_delegate tz4)\n | Ed25519 _ | Secp256k1 _ | P256 _ -> return_unit\n\nlet find = Storage.Contract.Delegate.find\n\ntype delegate_status =\n | Delegate\n | Delegated of Signature.Public_key_hash.t\n | Undelegated\n\nlet get_delegate_status ctxt pkh =\n let open Lwt_result_syntax in\n let+ delegate = find ctxt (Contract_repr.Implicit pkh) in\n match delegate with\n | None -> Undelegated\n | Some delegate when Signature.Public_key_hash.(delegate = pkh) -> Delegate\n | Some delegate -> Delegated delegate\n\nlet is_delegate ctxt pkh =\n let open Lwt_result_syntax in\n let+ find_res = get_delegate_status ctxt pkh in\n match find_res with Delegate -> true | Delegated _ | Undelegated -> false\n\nlet init ctxt contract delegate =\n let open Lwt_result_syntax in\n let*? () = check_not_tz4 delegate in\n let* ctxt = Storage.Contract.Delegate.init ctxt contract delegate in\n let delegate_contract = Contract_repr.Implicit delegate in\n let*! ctxt =\n Storage.Contract.Delegated.add (ctxt, delegate_contract) contract\n in\n return ctxt\n\nlet unlink ctxt contract =\n let open Lwt_result_syntax in\n let* delegate_opt = Storage.Contract.Delegate.find ctxt contract in\n match delegate_opt with\n | None -> return ctxt\n | Some delegate ->\n let delegate_contract = Contract_repr.Implicit delegate in\n let*! ctxt =\n Storage.Contract.Delegated.remove (ctxt, delegate_contract) contract\n in\n return ctxt\n\nlet delete ctxt contract =\n let open Lwt_result_syntax in\n let* ctxt = unlink ctxt contract in\n let*! ctxt = Storage.Contract.Delegate.remove ctxt contract in\n return ctxt\n\nlet set ctxt contract delegate =\n let open Lwt_result_syntax in\n let*? () = check_not_tz4 delegate in\n let* ctxt = unlink ctxt contract in\n let*! ctxt = Storage.Contract.Delegate.add ctxt contract delegate in\n let delegate_contract = Contract_repr.Implicit delegate in\n let*! ctxt =\n Storage.Contract.Delegated.add (ctxt, delegate_contract) contract\n in\n return ctxt\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_delegates_with_minimal_stake}\n - {!Storage.Stake.Total_active_stake}\n*)\n\nval initialize_delegate :\n Raw_context.t ->\n Signature.public_key_hash ->\n delegated:Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval get_full_staking_balance :\n Raw_context.t ->\n Signature.public_key_hash ->\n Full_staking_balance_repr.t tzresult Lwt.t\n\nval remove_delegated_stake :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval remove_frozen_stake_only_call_from_token :\n Raw_context.t ->\n Frozen_staker_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval add_delegated_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_frozen_stake_only_call_from_token :\n Raw_context.t ->\n Frozen_staker_repr.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\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 the public key hash of a delegate. *)\nval fold_on_active_delegates_with_minimal_stake_es :\n Raw_context.t ->\n f:(Signature.Public_key_hash.t -> 'a -> 'a tzresult Lwt.t) ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n 'a 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 * Stake_repr.t) list ->\n Stake_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 fold_on_active_delegates_with_minimal_stake_s :\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\nval get_selected_distribution :\n Raw_context.t ->\n Cycle_repr.t ->\n (Signature.Public_key_hash.t * Stake_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 * Stake_repr.t) list option tzresult Lwt.t\n\nval get_selected_distribution_as_map :\n Raw_context.t ->\n Cycle_repr.t ->\n Stake_repr.t Signature.Public_key_hash.Map.t 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 -> Stake_repr.t tzresult Lwt.t\n\n(** [add_contract_delegated_stake ctxt contract amount] calls\n [Stake_storage.add_delegated_stake ctxt delegate amount] if\n [contract] has a [delegate]. Otherwise this function does\n nothing. *)\nval add_contract_delegated_stake :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [remove_contract_delegated_stake ctxt contract amount] calls\n [Stake_storage.remove_delegated_stake ctxt delegate amount] if\n [contract] has a [delegate]. Otherwise this function does\n nothing. *)\nval remove_contract_delegated_stake :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\nval cleanup_values_for_protocol_p :\n Raw_context.t ->\n preserved_cycles:int ->\n consensus_rights_delay:int ->\n new_cycle:Cycle_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nmodule For_RPC : sig\n val get_staking_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\nend\n\nmodule Internal_for_tests : sig\n (** Same as [get_staking_balance] but returns zero if the argument\n is not an active delegate above minimal stake. *)\n val get :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\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\nmodule Selected_distribution_for_cycle = struct\n module Cache_client = struct\n type cached_value = (Signature.Public_key_hash.t * Stake_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 open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let* ctxt =\n Storage.Stake.Selected_distribution_for_cycle.init ctxt cycle stakes\n in\n let size = 1 (* that's symbolic: 1 cycle = 1 entry *) in\n let*? ctxt = Cache.update ctxt id (Some (stakes, size)) in\n return ctxt\n\n let get ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let* value_opt = Cache.find ctxt id in\n match value_opt with\n | None -> Storage.Stake.Selected_distribution_for_cycle.get ctxt cycle\n | Some v -> return v\n\n let find ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let* value_opt = Cache.find ctxt id in\n match value_opt with\n | None -> Storage.Stake.Selected_distribution_for_cycle.find ctxt cycle\n | Some _ as some_v -> return some_v\n\n let remove_existing ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let*? ctxt = Cache.update ctxt id None in\n Storage.Stake.Selected_distribution_for_cycle.remove_existing ctxt cycle\n\n let remove ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let*? ctxt = Cache.update ctxt id None in\n let*! ctxt =\n Storage.Stake.Selected_distribution_for_cycle.remove ctxt cycle\n in\n return ctxt\nend\n\nlet get_full_staking_balance = Storage.Stake.Staking_balance.get\n\nlet has_minimal_stake ctxt staking_balance =\n let minimal_stake = Constants_storage.minimal_stake ctxt in\n Full_staking_balance_repr.has_minimal_stake_to_be_considered\n ~minimal_stake\n staking_balance\n\nlet initialize_delegate ctxt delegate ~delegated =\n let open Lwt_result_syntax in\n let current_level = Raw_context.current_level ctxt in\n let balance =\n Full_staking_balance_repr.init\n ~own_frozen:Tez_repr.zero\n ~staked_frozen:Tez_repr.zero\n ~delegated\n ~current_level\n in\n let* ctxt = Storage.Stake.Staking_balance.init ctxt delegate balance in\n if has_minimal_stake ctxt balance then\n let*! ctxt =\n Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate\n in\n return ctxt\n else return ctxt\n\nlet update_stake ~f ctxt delegate =\n let open Lwt_result_syntax in\n let* staking_balance_before = get_full_staking_balance ctxt delegate in\n let*? staking_balance = f staking_balance_before in\n let* ctxt =\n Storage.Stake.Staking_balance.update ctxt delegate staking_balance\n in\n (* Since the staking balance has changed, the delegate might have\n moved across the minimal stake barrier. If so we may need to\n update the set of active delegates with minimal stake. *)\n let had_minimal_stake_before =\n has_minimal_stake ctxt staking_balance_before\n in\n let has_minimal_stake_after = has_minimal_stake ctxt staking_balance in\n match (had_minimal_stake_before, has_minimal_stake_after) with\n | true, false ->\n (* Decrease below the minimal stake. *)\n let* inactive = Delegate_activation_storage.is_inactive ctxt delegate in\n if inactive then\n (* The delegate is inactive so it wasn't in the set and we\n don't need to update it. *)\n return ctxt\n else\n let*! ctxt =\n Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate\n in\n return ctxt\n | false, true ->\n (* Increase above the minimal stake. *)\n let* inactive = Delegate_activation_storage.is_inactive ctxt delegate in\n if inactive then\n (* The delegate is inactive so we don't need to add it to the\n set. *)\n return ctxt\n else\n let*! ctxt =\n Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate\n in\n return ctxt\n | false, false | true, true -> return ctxt\n\nlet remove_delegated_stake ctxt delegate amount =\n let current_level = Raw_context.current_level ctxt in\n let f = Full_staking_balance_repr.remove_delegated ~current_level ~amount in\n update_stake ctxt delegate ~f\n\nlet remove_own_frozen_stake ctxt delegate amount =\n let f = Full_staking_balance_repr.remove_own_frozen ~amount in\n update_stake ctxt delegate ~f\n\nlet remove_staked_frozen_stake ctxt delegate amount =\n let f = Full_staking_balance_repr.remove_staked_frozen ~amount in\n update_stake ctxt delegate ~f\n\nlet remove_frozen_stake_only_call_from_token ctxt staker amount =\n match staker with\n | Frozen_staker_repr.Baker delegate ->\n remove_own_frozen_stake ctxt delegate amount\n | Frozen_staker_repr.Baker_edge delegate ->\n (* This case should not happen because [Baker_edge] is only\n intended to be used for rewards. *)\n remove_own_frozen_stake ctxt delegate amount\n | Single_staker {staker = _; delegate} | Shared_between_stakers {delegate} ->\n remove_staked_frozen_stake ctxt delegate amount\n\nlet add_delegated_stake ctxt delegate amount =\n let current_level = Raw_context.current_level ctxt in\n let f = Full_staking_balance_repr.add_delegated ~current_level ~amount in\n update_stake ctxt delegate ~f\n\nlet add_own_frozen_stake ctxt delegate amount =\n let f = Full_staking_balance_repr.add_own_frozen ~amount in\n update_stake ctxt delegate ~f\n\nlet add_staked_frozen_stake ctxt delegate amount =\n let f = Full_staking_balance_repr.add_staked_frozen ~amount in\n update_stake ctxt delegate ~f\n\nlet add_frozen_stake_only_call_from_token ctxt staker amount =\n match staker with\n | Frozen_staker_repr.Baker delegate ->\n add_own_frozen_stake ctxt delegate amount\n | Frozen_staker_repr.Baker_edge delegate ->\n add_own_frozen_stake ctxt delegate amount\n | Single_staker {staker = _; delegate} | Shared_between_stakers {delegate} ->\n add_staked_frozen_stake ctxt delegate amount\n\nlet set_inactive ctxt delegate =\n let open Lwt_syntax in\n let* ctxt = Delegate_activation_storage.set_inactive ctxt delegate in\n Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate\n\nlet set_active ctxt delegate =\n let open Lwt_result_syntax in\n let* ctxt, inactive = Delegate_activation_storage.set_active ctxt delegate in\n if not inactive then return ctxt\n else\n let* staking_balance = get_full_staking_balance ctxt delegate in\n if has_minimal_stake ctxt staking_balance then\n let*! ctxt =\n Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate\n in\n return ctxt\n else return ctxt\n\nlet set_selected_distribution_for_cycle ctxt cycle stakes total_stake =\n let open Lwt_result_syntax in\n let stakes = List.sort (fun (_, x) (_, y) -> Stake_repr.compare y x) stakes in\n let* ctxt = Selected_distribution_for_cycle.init ctxt cycle stakes in\n let*! ctxt = Storage.Stake.Total_active_stake.add ctxt cycle total_stake in\n return ctxt\n\nlet fold_on_active_delegates_with_minimal_stake_es ctxt ~f ~order ~init =\n let open Lwt_result_syntax in\n Storage.Stake.Active_delegates_with_minimal_stake.fold\n ctxt\n ~order\n ~init:(Ok init)\n ~f:(fun delegate acc ->\n let*? acc in\n f delegate acc)\n\nlet clear_at_cycle_end ctxt ~new_cycle =\n let open Lwt_result_syntax in\n let max_slashing_period = Constants_repr.max_slashing_period in\n match Cycle_repr.sub new_cycle max_slashing_period with\n | None -> return ctxt\n | Some cycle_to_clear ->\n let* ctxt =\n Storage.Stake.Total_active_stake.remove_existing ctxt cycle_to_clear\n in\n Selected_distribution_for_cycle.remove_existing ctxt cycle_to_clear\n\nlet fold_on_active_delegates_with_minimal_stake_s =\n Storage.Stake.Active_delegates_with_minimal_stake.fold\n\nlet get_selected_distribution = Selected_distribution_for_cycle.get\n\nlet find_selected_distribution = Selected_distribution_for_cycle.find\n\nlet get_selected_distribution_as_map ctxt cycle =\n let open Lwt_result_syntax in\n let+ stakes = Selected_distribution_for_cycle.get ctxt cycle in\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\nlet prepare_stake_distribution ctxt =\n let open Lwt_result_syntax in\n let level = Level_storage.current ctxt in\n let+ stake_distribution = get_selected_distribution_as_map ctxt level.cycle in\n Raw_context.init_stake_distribution_for_current_cycle ctxt stake_distribution\n\nlet get_total_active_stake = Storage.Stake.Total_active_stake.get\n\nlet remove_contract_delegated_stake ctxt contract amount =\n let open Lwt_result_syntax in\n let* delegate_opt = Contract_delegate_storage.find ctxt contract in\n match delegate_opt with\n | None -> return ctxt\n | Some delegate -> remove_delegated_stake ctxt delegate amount\n\nlet add_contract_delegated_stake ctxt contract amount =\n let open Lwt_result_syntax in\n let* delegate_opt = Contract_delegate_storage.find ctxt contract in\n match delegate_opt with\n | None -> return ctxt\n | Some delegate -> add_delegated_stake ctxt delegate amount\n\n(* let's assume that consensus_rights_delay <= preserved_cycles;\n we need to keep [ new_cycles; new_cycles + consensus_rights_delay ]\n and remove the rest, i.e.,\n [ new_cycles + consensus_rights_delay + 1; new_cycles + preserved_cycles ] *)\nlet cleanup_values_for_protocol_p ctxt ~preserved_cycles ~consensus_rights_delay\n ~new_cycle =\n let open Lwt_result_syntax in\n assert (Compare.Int.(consensus_rights_delay <= preserved_cycles)) ;\n if Compare.Int.(consensus_rights_delay = preserved_cycles) then return ctxt\n else\n let start_cycle = Cycle_repr.add new_cycle (consensus_rights_delay + 1) in\n let end_cycle = Cycle_repr.add new_cycle preserved_cycles in\n List.fold_left_es\n (fun ctxt cycle_to_clear ->\n let*! ctxt =\n Storage.Stake.Total_active_stake.remove ctxt cycle_to_clear\n in\n Selected_distribution_for_cycle.remove ctxt cycle_to_clear)\n ctxt\n Cycle_repr.(start_cycle ---> end_cycle)\n\nmodule For_RPC = struct\n let get_staking_balance ctxt delegate =\n let open Lwt_result_syntax in\n let* staking_balance = Storage.Stake.Staking_balance.get ctxt delegate in\n Lwt.return (Full_staking_balance_repr.current_total staking_balance)\nend\n\nmodule Internal_for_tests = struct\n let get ctxt delegate =\n let open Lwt_result_syntax in\n let*! result =\n Storage.Stake.Active_delegates_with_minimal_stake.mem ctxt delegate\n in\n match result with\n | true -> For_RPC.get_staking_balance ctxt delegate\n | false -> return Tez_repr.zero\nend\n" ;
} ;
{ name = "Unstaked_frozen_deposits_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 unstaked frozen deposits.\n\n Unstaked frozen deposits are tez coming from frozen deposits that have been\n unstaked, either:\n - manually with the \"unstake\" pseudo-operation,\n - automatically at cycle ends with the auto-staking mechanism, or\n - when a delegator changes delegate.\n The amounts are attached to a given cycle, the cycle at which the unstake\n happened, and are slashable for another\n [consensus_rights_delay + max_slashing_period - 1] cycles. After this, they can be\n finalized either with the \"finalize_unstake\" pseudo-operation, via\n auto-staking (for bakers only), or when staking or unstaking.\n\n Unstaked frozen deposits contain, for each cycle, a [current_amount] and an\n [initial_amount].\n Only unstaked frozen deposits for the current cycles can be increased, via\n unstaking.\n After a cycle has ended, the initial amount becomes the basis for\n forthcoming slashings. It can only be decreased by the\n \"stake from unstake\" mechanism.\n Slashings only affects the [current_amount] of the slashed cycles.\n\n Unstaked frozen deposits of finished cycles can be decreased by the\n \"stake from unstake\" mechanism, but only if the cycles haven't been slashed\n (to avoid shooting ourselves in the feet).\n\n To avoid the list of cycles growing unboundedly, amounts for finalizable\n cycles are squashed together, lazily, when the list needs to be updated,\n only.\n\n This module is responsible for maintaining the\n {!Storage.Contract.Unstaked_frozen_deposits} table. *)\n\n(** [balance ctxt delegate cycle] returns the amount of unstaked frozen deposits\n for [delegate] at [cycle].\n If [cycle] is an unslashable cycle, the returned amount is the squashed\n amount of all the unslashable cycles. *)\nval balance :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Cycle_repr.t ->\n Tez_repr.t tzresult Lwt.t\n\n(** [get] acts like [balance] but returns both the initial amount and the\n current amount. *)\nval get :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Cycle_repr.t ->\n Deposits_repr.t tzresult Lwt.t\n\n(** [credit_only_call_from_token ctxt staker cycle amount] credits the\n unstaked frozen deposits for [staker] at [cycle] by [amount].\n If [cycle] is an unslashable cycle, the credited cycle is the last\n unslashable cycle. *)\nval credit_only_call_from_token :\n Raw_context.t ->\n Unstaked_frozen_staker_repr.t ->\n Cycle_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [spend_only_call_from_token ctxt staker cycle amount] spends [amount]\n from the unstaked frozen deposits for [staker] at [cycle].\n If [cycle] is an unslashable cycle, the amount is spent from the last\n unslashable cycle.\n The function returns the error [Subtraction_underflow] if the balance is\n too low. *)\nval spend_only_call_from_token :\n Raw_context.t ->\n Unstaked_frozen_staker_repr.t ->\n Cycle_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [decrease_initial_amount_only_for_stake_from_unstake ctxt staker cycle amount]\n decreases [amount] from the unstaked frozen deposits for [staker] at [cycle].\n It is only called if the cycle hasn't been slashed, so the amount removed is\n the same as the amount spent in [current_amount].\n*)\nval decrease_initial_amount_only_for_stake_from_unstake :\n Raw_context.t ->\n Signature.public_key_hash ->\n Cycle_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 current_unslashable_cycle ctxt =\n let cycle = (Raw_context.current_level ctxt).cycle in\n let slashable_deposits_period =\n Constants_storage.slashable_deposits_period ctxt\n in\n let max_slashing_period = Constants_repr.max_slashing_period in\n Cycle_repr.sub cycle (slashable_deposits_period + max_slashing_period)\n\nlet get_all ctxt contract =\n let open Lwt_result_syntax in\n let* unstaked_frozen_deposits_opt =\n Storage.Contract.Unstaked_frozen_deposits.find ctxt contract\n in\n let unslashable_cycle = current_unslashable_cycle ctxt in\n match unstaked_frozen_deposits_opt with\n | None -> return (Unstaked_frozen_deposits_repr.empty ~unslashable_cycle)\n | Some unstaked_frozen_deposits ->\n Lwt.return\n @@ Unstaked_frozen_deposits_repr.squash_unslashable\n ~unslashable_cycle\n unstaked_frozen_deposits\n\nlet get ctxt delegate cycle =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Implicit delegate in\n let+ unstaked_frozen_deposits = get_all ctxt contract in\n Unstaked_frozen_deposits_repr.get cycle unstaked_frozen_deposits\n\nlet balance ctxt delegate cycle =\n let open Lwt_result_syntax in\n let+ frozen_deposits = get ctxt delegate cycle in\n frozen_deposits.current_amount\n\nlet update_balance ~f ctxt delegate_contract cycle =\n let open Lwt_result_syntax in\n let* unstaked_frozen_deposits = get_all ctxt delegate_contract in\n let*? unstaked_frozen_deposits =\n Unstaked_frozen_deposits_repr.update ~f cycle unstaked_frozen_deposits\n in\n let*! ctxt =\n Storage.Contract.Unstaked_frozen_deposits.add\n ctxt\n delegate_contract\n unstaked_frozen_deposits.t\n in\n return ctxt\n\nlet credit_only_call_from_token ctxt staker cycle amount =\n let open Lwt_result_syntax in\n let delegate = Unstaked_frozen_staker_repr.delegate staker in\n let delegate_contract = Contract_repr.Implicit delegate in\n let f deposits = Deposits_repr.(deposits +? amount) in\n let* ctxt = Stake_storage.add_delegated_stake ctxt delegate amount in\n update_balance ~f ctxt delegate_contract cycle\n\nlet spend_only_call_from_token ctxt staker cycle amount =\n let open Lwt_result_syntax in\n let delegate = Unstaked_frozen_staker_repr.delegate staker in\n let delegate_contract = Contract_repr.Implicit delegate in\n let f Deposits_repr.{initial_amount; current_amount} =\n let open Result_syntax in\n let+ current_amount = Tez_repr.(current_amount -? amount) in\n Deposits_repr.{initial_amount; current_amount}\n in\n let* ctxt = Stake_storage.remove_delegated_stake ctxt delegate amount in\n update_balance ~f ctxt delegate_contract cycle\n\nlet decrease_initial_amount_only_for_stake_from_unstake ctxt delegate cycle\n amount =\n let delegate_contract = Contract_repr.Implicit delegate in\n let f Deposits_repr.{initial_amount; current_amount} =\n let open Result_syntax in\n let+ initial_amount = Tez_repr.(initial_amount -? amount) in\n Deposits_repr.{initial_amount; current_amount}\n in\n update_balance ~f ctxt delegate_contract cycle\n" ;
} ;
{ name = "Pending_denunciations_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2024 Nomadic Labs. <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n(** This module deals with pending denunciations before they are used to slash\n delegates.\n\n This module is responsible for maintaining the table\n {!Storage.Pending_denunciations}\n\n In particular, it maintains the invariant that no key is pointing to an\n empty denunciation list.\n*)\n\n(** Returns the pending denunciations list of the given delegate.\n It returns an empty list if none are registered.\n *)\nval find :\n Raw_context.t ->\n Signature.public_key_hash ->\n Denunciations_repr.item list tzresult Lwt.t\n\n(** Add a denunciation in the list of the given delegate *)\nval add_denunciation :\n Raw_context.t ->\n misbehaving_delegate:Signature.public_key_hash ->\n Operation_hash.t ->\n rewarded_delegate:Signature.public_key_hash ->\n Misbehaviour_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Set the denunciation list of the given delegate.\n Previously set denunciations would be erased.\n*)\nval set_denunciations :\n Raw_context.t ->\n Signature.public_key_hash ->\n Denunciations_repr.t ->\n Raw_context.t Lwt.t\n\n(** Tells if the given delegate has some pending denunciations *)\nval has_pending_denunciations :\n Raw_context.t -> Signature.public_key_hash -> bool Lwt.t\n\n(** See {!Storage.Pending_denunciations.fold} *)\nval fold :\n Raw_context.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:\n (Signature.public_key_hash ->\n Denunciations_repr.item list ->\n 'a ->\n 'a Lwt.t) ->\n 'a Lwt.t\n\n(** See {!Storage.Pending_denunciations.clear} *)\nval clear : Raw_context.t -> Raw_context.t Lwt.t\n\nmodule For_RPC : sig\n (** Returns a list of all denunciations paired with the offending delegate pkh. *)\n val pending_denunciations_list :\n Raw_context.t ->\n (Signature.public_key_hash * Denunciations_repr.item) list Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2024 Nomadic Labs. <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\nlet find ctxt delegate =\n let open Lwt_result_syntax in\n let* denunciations_opt = Storage.Pending_denunciations.find ctxt delegate in\n return @@ Option.value denunciations_opt ~default:[]\n\nlet add_denunciation ctxt ~misbehaving_delegate operation_hash\n ~rewarded_delegate misbehaviour =\n let open Lwt_result_syntax in\n let* denunciations = find ctxt misbehaving_delegate in\n let denunciations =\n Denunciations_repr.add\n operation_hash\n rewarded_delegate\n misbehaviour\n denunciations\n in\n let*! ctxt =\n Storage.Pending_denunciations.add ctxt misbehaving_delegate denunciations\n in\n return ctxt\n\nlet set_denunciations ctxt delegate denunciations =\n match denunciations with\n | [] -> Storage.Pending_denunciations.remove ctxt delegate\n | _ -> Storage.Pending_denunciations.add ctxt delegate denunciations\n\nlet has_pending_denunciations ctxt delegate =\n (* we rely here on the fact that we never insert an empty list in the table *)\n Storage.Pending_denunciations.mem ctxt delegate\n\nlet fold = Storage.Pending_denunciations.fold\n\nlet clear ctxt = Storage.Pending_denunciations.clear ctxt\n\nmodule For_RPC = struct\n let pending_denunciations_list ctxt =\n let open Lwt_syntax in\n let+ r = Storage.Pending_denunciations.bindings ctxt in\n List.map (fun (x, l) -> List.map (fun y -> (x, y)) l) r |> List.flatten\nend\n" ;
} ;
{ name = "Unstake_requests_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 unstake requests.\n\n This module is responsible for maintaining the\n {!Storage.Contract.Unstake_requests} table. *)\n\ntype finalizable =\n (Signature.Public_key_hash.t * Cycle_repr.t * Tez_repr.t) list\n\ntype stored_requests = Storage.Unstake_request.t = {\n delegate : Signature.Public_key_hash.t;\n requests : (Cycle_repr.t * Tez_repr.t) list;\n}\n\ntype prepared_finalize_unstake = {\n finalizable : finalizable;\n unfinalizable : stored_requests;\n}\n\nval prepared_finalize_unstake_encoding :\n prepared_finalize_unstake Data_encoding.encoding\n\n(** [prepare_finalize_unstake ctxt ~for_next_cycle_use_only_after_slashing contract]\n preprocesses a [finalize_unstake] for [contract]. It returns a\n list of transfers [(d, c, a)] to do from delegate's [d] unstaked frozen\n deposits for cycle [c] of amount [a] in the [finalizable_field] as well as\n the remaining unfinalizable requests that should be kept in the storage in\n [unfinalizable].\n\n It returns [None] if there are no unstake requests.\n\n If [for_next_cycle_use_only_after_slashing] is true, the finalisation is\n done for the next cycle. It is meant to be used only at cycle end after the\n application of the slashing.\n\n *)\nval prepare_finalize_unstake :\n Raw_context.t ->\n for_next_cycle_use_only_after_slashing:bool ->\n Contract_repr.t ->\n prepared_finalize_unstake option tzresult Lwt.t\n\n(** [update ctxt contract requests] updates unstake requests for [contract]. *)\nval update :\n Raw_context.t ->\n Contract_repr.t ->\n stored_requests ->\n Raw_context.t tzresult Lwt.t\n\n(** [add ctxt ~contract ~delegate cycle amount] adds a request from [contract]\n to unstake [amount] from [delegate] at cycle [cycle].\n\n @raises Assert_failure if [contract] already has unstake requests from another\n delegate (broken invariant). *)\nval add :\n Raw_context.t ->\n contract:Contract_repr.t ->\n delegate:Signature.Public_key_hash.t ->\n Cycle_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Slow functions only used for RPCs *)\nmodule For_RPC : sig\n (** Apply current slash history to unfinalizable unstake requests.\n [prepare_finalize_unstake] does not compute this value because it is never\n used internally. However, we need to apply slashes anyways when trying to\n compute the accurate balance of a staker *)\n val apply_slash_to_unstaked_unfinalizable :\n Raw_context.t ->\n stored_requests ->\n (Cycle_repr.t * Tez_repr.t) list tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 | Cannot_unstake_with_unfinalizable_unstake_requests_to_another_delegate\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\n \"operation.cannot_unstake_with_unfinalizable_unstake_requests_to_another_delegate\"\n ~title:\n \"Cannot unstake with unfinalizable unstake requests to another delegate\"\n ~description:\n \"Cannot unstake with unfinalizable unstake requests to another delegate\"\n Data_encoding.unit\n (function\n | Cannot_unstake_with_unfinalizable_unstake_requests_to_another_delegate\n ->\n Some ()\n | _ -> None)\n (fun () ->\n Cannot_unstake_with_unfinalizable_unstake_requests_to_another_delegate)\n\ntype finalizable =\n (Signature.Public_key_hash.t * Cycle_repr.t * Tez_repr.t) list\n\nlet finalizable_encoding =\n let open Data_encoding in\n let elt_encoding =\n obj3\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"cycle\" Cycle_repr.encoding)\n (req \"amount\" Tez_repr.encoding)\n in\n list elt_encoding\n\ntype stored_requests = Storage.Unstake_request.t = {\n delegate : Signature.Public_key_hash.t;\n requests : (Cycle_repr.t * Tez_repr.t) list;\n}\n\nlet stored_requests_encoding =\n let open Data_encoding in\n let request_encoding =\n obj2 (req \"cycle\" Cycle_repr.encoding) (req \"amount\" Tez_repr.encoding)\n in\n conv\n (fun {delegate; requests} -> (delegate, requests))\n (fun (delegate, requests) -> {delegate; requests})\n (obj2\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"requests\" (list request_encoding)))\n\ntype prepared_finalize_unstake = {\n finalizable : finalizable;\n unfinalizable : stored_requests;\n}\n\nlet prepared_finalize_unstake_encoding :\n prepared_finalize_unstake Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {finalizable; unfinalizable} -> (finalizable, unfinalizable))\n (fun (finalizable, unfinalizable) -> {finalizable; unfinalizable})\n (obj2\n (req \"finalizable\" finalizable_encoding)\n (req \"unfinalizable\" stored_requests_encoding))\n\nlet apply_slashes ~slashable_deposits_period slashing_history ~from_cycle amount\n =\n let first_cycle_to_apply_slash = from_cycle in\n let last_cycle_to_apply_slash =\n Cycle_repr.add from_cycle slashable_deposits_period\n in\n (* [slashing_history] is sorted so slashings always happen in the same order. *)\n List.fold_left\n (fun remain (slashing_cycle, slashing_percentage) ->\n if\n Cycle_repr.(\n slashing_cycle >= first_cycle_to_apply_slash\n && slashing_cycle <= last_cycle_to_apply_slash)\n then\n Tez_repr.(\n sub_opt\n remain\n (mul_percentage ~rounding:`Up amount slashing_percentage))\n |> Option.value ~default:Tez_repr.zero\n else remain)\n amount\n slashing_history\n\nlet prepare_finalize_unstake ctxt ~for_next_cycle_use_only_after_slashing\n contract =\n let open Lwt_result_syntax in\n let slashable_deposits_period =\n Constants_storage.slashable_deposits_period ctxt\n in\n let max_slashing_period = Constants_repr.max_slashing_period in\n let slashable_plus_denunciation_delay =\n slashable_deposits_period + max_slashing_period\n in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let current_cycle =\n if for_next_cycle_use_only_after_slashing then Cycle_repr.succ current_cycle\n else current_cycle\n in\n let* requests_opt = Storage.Contract.Unstake_requests.find ctxt contract in\n match requests_opt with\n | None | Some {delegate = _; requests = []} -> return_none\n | Some {delegate; requests} -> (\n match Cycle_repr.sub current_cycle slashable_plus_denunciation_delay with\n | None (* no finalizable cycle *) ->\n return_some {finalizable = []; unfinalizable = {delegate; requests}}\n | Some greatest_finalizable_cycle ->\n let* slashing_history_opt =\n Storage.Slashed_deposits.find ctxt delegate\n in\n let slashing_history =\n Option.value slashing_history_opt ~default:[]\n in\n (* Oxford values *)\n let* slashing_history_opt_o =\n Storage.Contract.Slashed_deposits__Oxford.find\n ctxt\n (Contract_repr.Implicit delegate)\n in\n let slashing_history_o =\n Option.value slashing_history_opt_o ~default:[]\n |> List.map (fun (a, b) -> (a, Percentage.convert_from_o_to_p b))\n in\n\n let slashing_history =\n List.fold_left\n (fun acc (cycle, percentage) ->\n Storage.Slashed_deposits_history.add cycle percentage acc)\n slashing_history_o\n slashing_history\n in\n let finalizable, unfinalizable_requests =\n List.partition_map\n (fun request ->\n let request_cycle, request_amount = request in\n if Cycle_repr.(request_cycle <= greatest_finalizable_cycle) then\n let new_amount =\n apply_slashes\n ~slashable_deposits_period\n slashing_history\n ~from_cycle:request_cycle\n request_amount\n in\n Left (delegate, request_cycle, new_amount)\n else Right request)\n requests\n in\n let unfinalizable =\n Storage.Unstake_request.\n {delegate; requests = unfinalizable_requests}\n in\n return_some {finalizable; unfinalizable})\n\nlet update = Storage.Contract.Unstake_requests.update\n\nlet add ctxt ~contract ~delegate cycle amount =\n let open Lwt_result_syntax in\n let* requests_opt = Storage.Contract.Unstake_requests.find ctxt contract in\n let*? requests =\n match requests_opt with\n | None -> Ok []\n | Some {delegate = request_delegate; requests} -> (\n match requests with\n | [] -> Ok []\n | _ ->\n if Signature.Public_key_hash.(delegate <> request_delegate) then\n (* This would happen if the staker was allowed to stake towards\n a new delegate while having unfinalizable unstake requests,\n which is not allowed: it will fail earlier. Also, unstaking\n for 0 tez is a noop and does not change the state of the storage,\n so it does not allow to reach this error either. *)\n Result_syntax.tzfail\n Cannot_unstake_with_unfinalizable_unstake_requests_to_another_delegate\n else Ok requests)\n in\n let*? requests = Storage.Unstake_request.add cycle amount requests in\n let unstake_request = Storage.Unstake_request.{delegate; requests} in\n let*! ctxt =\n Storage.Contract.Unstake_requests.add ctxt contract unstake_request\n in\n return ctxt\n\nmodule For_RPC = struct\n let apply_slash_to_unstaked_unfinalizable ctxt {requests; delegate} =\n let open Lwt_result_syntax in\n let slashable_deposits_period =\n Constants_storage.slashable_deposits_period ctxt\n in\n let* slashing_history_opt = Storage.Slashed_deposits.find ctxt delegate in\n let slashing_history = Option.value slashing_history_opt ~default:[] in\n\n (* Oxford values *)\n let* slashing_history_opt =\n Storage.Contract.Slashed_deposits__Oxford.find\n ctxt\n (Contract_repr.Implicit delegate)\n in\n let slashing_history_o =\n Option.value slashing_history_opt ~default:[]\n |> List.map (fun (a, b) -> (a, Percentage.convert_from_o_to_p b))\n in\n\n let slashing_history =\n List.fold_left\n (fun acc (cycle, percentage) ->\n Storage.Slashed_deposits_history.add cycle percentage acc)\n slashing_history_o\n slashing_history\n in\n\n List.map_es\n (fun (request_cycle, request_amount) ->\n let new_amount =\n apply_slashes\n ~slashable_deposits_period\n slashing_history\n ~from_cycle:request_cycle\n request_amount\n in\n return (request_cycle, new_amount))\n requests\nend\n" ;
} ;
{ name = "Staking_pseudotokens_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 responsible for maintaining the\n {!Storage.Contract.Frozen_deposits_pseudotokens} and\n {!Storage.Contract.Staking_pseudotokens} tables. *)\n\n(** [stake ctxt ~contract ~delegate amount] credits the [contract]'s\n staking pseudotokens and the [delegate]'s frozen deposits pseudotokens by\n an amount of pseudotokens corresponding to [amount] using [delegate]'s\n staked frozen deposits pseudotokens/tez rate.\n\n This function must be called on \"stake\" **before** transferring tez to\n [delegate]'s frozen deposits.\n\n [delegate] must be [contract]'s delegate. *)\nval stake :\n Raw_context.t ->\n contract:Contract_repr.t ->\n delegate:Signature.Public_key_hash.t ->\n Tez_repr.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [request_unstake ctxt ~contract ~delegate amount] debits the [contract]'s\n staking pseudotokens and the [delegate]'s frozen deposits pseudotokens by\n an amount of pseudotokens corresponding to [amount] using [delegate]'s\n staked frozen deposits pseudotokens/tez rate capped by [contract]'s staking\n pseudotokens balance.\n\n It returns the tez amount corresponding to the debited pseudotokens.\n\n Resulting context do not make sense if [delegate] is not [contract]'s\n delegate. *)\nval request_unstake :\n Raw_context.t ->\n contract:Contract_repr.t ->\n delegate:Signature.Public_key_hash.t ->\n Tez_repr.t ->\n (Raw_context.t * Tez_repr.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\nmodule For_RPC : sig\n (** [staked_balance ctxt ~contract ~delegate] returns [contract]'s\n current staked tez.\n For delegate, it is their own frozen deposits.\n For delegators, their staking balance in pseudotokens is converted into tez\n using [delegate]'s staked frozen deposits tez/pseudotokens rate.\n\n The given [delegate] should be [contract]'s delegate. Otherwise the given\n [Tez.t] amount will not make sense. *)\n val staked_balance :\n Raw_context.t ->\n contract:Contract_repr.t ->\n delegate:Signature.Public_key_hash.t ->\n Tez_repr.t tzresult Lwt.t\n\n val staking_pseudotokens_balance :\n Raw_context.t ->\n delegator:Contract_repr.t ->\n Staking_pseudotoken_repr.t tzresult Lwt.t\n\n val get_frozen_deposits_pseudotokens :\n Raw_context.t ->\n delegate:Signature.public_key_hash ->\n Staking_pseudotoken_repr.t tzresult Lwt.t\n\n val get_frozen_deposits_staked_tez :\n Raw_context.t ->\n delegate:Signature.public_key_hash ->\n Tez_repr.t tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(** {0} Introduction\n\n This module is responsible for maintaining the\n {!Storage.Contract.Frozen_deposits_pseudotokens} and\n {!Storage.Contract.Staking_pseudotokens} tables.\n\n {1} Terminology\n\n Even so a registered delegate is always technically in a delegation\n relation with itself, in this module, when we use the word\n \"delegator\", we always mean a delegator different from the\n delegate itself. The word \"staker\" means for a delegator who\n participates in staking. The word \"staker\" means any participant\n in staking, either a delegate or a staker. In this module, we\n use the word \"contract\" to mean either a delegate or a delegator.\n\n {1} Full staking balance of a delegate\n\n For each delegate, the {!Stake_storage} module is responsible to\n track three tez quantities which can be requested with the\n {!Stake_storage.get_full_staking_balance} function: [own_frozen]\n is the frozen deposits of the delegate, [staked_frozen] is the\n sum of all frozen deposits of its stakers, and [delegate] is the\n sum of all tez delegated to the delegate (some of which may belong\n to the delegate itself). This module is in charge of tracking the\n frozen deposits of each staker. Since we already have access to\n their sum ([staked_frozen]) we only need to track the proportion\n of this sum owned by each staker.\n\n {1} Pseudo-tokens\n\n The {!Storage.Contract.Frozen_deposits_pseudotokens} and\n {!Storage.Contract.Staking_pseudotokens} tables are used to keep\n track of this proportion. The amounts stored in these tables don't\n have a fixed value in tez, they can be seen as shares of the total\n frozen deposits of a delegate's stakers, we call them\n pseudotokens. Pseudotokens are minted when a staker increases\n its share using the stake pseudo-operation; they are burnt when a\n staker decreases its share using the request-unstake\n pseudo-operation. Events which modify uniformly the frozen\n deposits of all the stakers of a delegate (reward distribution\n and slashing) don't lead to minting nor burning any pseudotokens;\n that's the main motivation for using these pseudotokens: thanks to\n them we never need to iterate over the stakers of a delegate\n (whose number is unbounded).\n\n\n {1} Conversion rate:\n\n The conversion rate between pseudotokens and mutez (the value in\n mutez of a pseudotoken) should be given by the ratio between the\n delegate's current staked frozen deposits and the total number\n of pseudotokens of the delegate; it's actually the case when this\n total number of pseudotokens is positive. When the total number of\n pseudotokens of a delegate is null, the conversion rate could\n theoretically have any value but extreme values are dangerous\n because of overflows and loss of precision; for these reasons, we\n use one as the conversion rate when the total number of\n pseudotokens is null, which can happen in two situations:\n\n - the first time a delegator stakes since the\n migration which created the pseudotoken tables, and\n\n - when stakers empty their delegate's staked frozen deposits and later\n receive rewards.\n\n\n {2} Implementation:\n\n The {!Storage.Contract.Staking_pseudotokens} table stores for\n each staker its {i staking balance pseudotokens} which is the\n number of pseudotokens owned by the staker.\n\n The {!Storage.Contract.Frozen_deposits_pseudotokens} table stores\n for each delegate the {i frozen deposits pseudotokens} of the\n delegate which is defined as the sum of all the staking balance\n pseudotokens of its stakers.\n\n For both tables, pseudotokens are represented using the\n [Pseudotoken_repr.t] type which is, like [Tez_repr.t], stored on\n non-negative signed int64.\n\n\n {2} Invariants:\n\n {3} Invariant 1: frozen deposits pseudotokens initialization\n\n For {!Storage.Contract.Frozen_deposits_pseudotokens}, a missing\n key is equivalent to a value of [0]. This case means that there are\n no pseudotokens, the delegate has no staker, the conversion rate is [1].\n\n {3} Invariant 2: staking balance pseudotokens initialization\n\n For {!Storage.Contract.Staking_pseudotokens}, a missing key is\n equivalent to a value of [0].\n\n {3} Invariant 3: relationship between frozen deposits and staking\n balance pseudotokens\n\n For a given delegate, their frozen deposits pseudotokens equal\n the sum of all staking pseudotokens of their delegators.\n\n {3} Invariant 4: delegates have no staking pseudotokens.\n*)\n\n(** When a delegate gets totally slashed, the value of its\n pseudotokens becomes 0 and before minting any new token we would\n need to iterate over all stakers to empty their pseudotoken\n balances. We want to avoid iterating over stakers so we forbid\n {b stake} in this case. *)\ntype error += Cannot_stake_on_fully_slashed_delegate\n\n(** These two types are not exported, they are views to the portions\n of the storage which are relevant in this module when a delegate\n or a staker are considered. *)\ntype delegate_balances = {\n delegate : Signature.public_key_hash;\n frozen_deposits_staked_tez : Tez_repr.t;\n frozen_deposits_pseudotokens : Staking_pseudotoken_repr.t;\n}\n\ntype delegator_balances = {\n delegator : Contract_repr.t;\n pseudotoken_balance : Staking_pseudotoken_repr.t;\n delegate_balances : delegate_balances;\n}\n\n(** {0} Functions reading from the storage *)\n\n(** [get_frozen_deposits_staked_tez ctxt ~delegate] returns the sum of frozen\n deposits, in tez, of the delegate's stakers. *)\nlet get_frozen_deposits_staked_tez ctxt ~delegate =\n let open Lwt_result_syntax in\n let+ staking_balance = Stake_storage.get_full_staking_balance ctxt delegate in\n Full_staking_balance_repr.staked_frozen staking_balance\n\nlet get_own_frozen_deposits ctxt ~delegate =\n let open Lwt_result_syntax in\n let+ staking_balance = Stake_storage.get_full_staking_balance ctxt delegate in\n Full_staking_balance_repr.own_frozen staking_balance\n\n(** [get_frozen_deposits_pseudotokens ctxt ~delegate] returns the total\n number of pseudotokens in circulation for the given\n [delegate]. This should, by invariant 3 be the sum of the\n staking balance (in pseudotokens) of all its delegators.\n\n To preserve invariant 1, this should be the only function of this\n module reading from the\n {!Storage.Contract.Frozen_deposits_pseudotokens} table. *)\nlet get_frozen_deposits_pseudotokens ctxt ~delegate =\n let open Lwt_result_syntax in\n let+ frozen_deposits_pseudotokens_opt =\n Storage.Contract.Frozen_deposits_pseudotokens.find ctxt (Implicit delegate)\n in\n Option.value\n frozen_deposits_pseudotokens_opt\n ~default:Staking_pseudotoken_repr.zero\n\n(** [staking_pseudotokens_balance ctxt ~delegator] returns\n [delegator]'s current staking balance in pseudotokens.\n\n To preserve invariant 2, this should be the only function of this\n module reading from the {!Storage.Contract.Staking_pseudotokens}\n table.\n*)\nlet staking_pseudotokens_balance ctxt ~delegator =\n let open Lwt_result_syntax in\n let+ staking_pseudotokens_opt =\n Storage.Contract.Staking_pseudotokens.find ctxt delegator\n in\n Option.value ~default:Staking_pseudotoken_repr.zero staking_pseudotokens_opt\n\n(** [get_delegate_balances ctxt ~delegate] records the staked frozen deposits\n in tez and pseudotokens of a given delegate.\n\n Postcondition:\n delegate = result.delegate /\\\n get_frozen_deposits_staked_tez ctxt ~delegate = return result.frozen_deposits_staked_tez /\\\n get_frozen_deposits_pseudotokens ctxt ~delegate = return result.frozen_deposits_pseudotokens\n*)\nlet get_delegate_balances ctxt ~delegate =\n let open Lwt_result_syntax in\n let* frozen_deposits_staked_tez =\n get_frozen_deposits_staked_tez ctxt ~delegate\n in\n let+ frozen_deposits_pseudotokens =\n get_frozen_deposits_pseudotokens ctxt ~delegate\n in\n {delegate; frozen_deposits_staked_tez; frozen_deposits_pseudotokens}\n\n(** [get_delegator_balances ctxt ~delegator ~delegate_balances] enriches\n the [delegate_balances] with [delegator]'s pseudotoken balance.\n\n Precondition:\n unchecked: [delegator != delegate_balance.delegate] /\\\n unchecked: [delegator] delegates to [delegate_balance.delegate]\n unchecked: get_delegate_balances ctxt ~delegate = return delegate_balances\n Postcondition:\n result.delegator = delegator /\\\n result.delegate_balances = delegate_balances /\\\n staking_pseudotokens_balance ctxt ~delegator = return result.pseudotoken_balance\n*)\nlet get_delegator_balances ctxt ~delegator ~delegate_balances =\n let open Lwt_result_syntax in\n let+ pseudotoken_balance = staking_pseudotokens_balance ctxt ~delegator in\n {delegator; pseudotoken_balance; delegate_balances}\n\n(** [mint_pseudotokens ctxt delegator_balances_before\n pseudotokens_to_mint] mints [pseudotokens_to_mint] pseudotokens\n and assign them to [delegator_balances_before.delegator]. Both\n tables are updated to maintain invariant 3.\n\n Precondition:\n unchecked: get_delegator_balances ctxt delegator_balances_before.delegator = return delegator_balances_before /\\\n unchecked: invariant3(ctxt)\n Postcondition:\n get_delegator_balances ctxt delegator_balances_before.delegator =\n return {delegator_balances_before with\n pseudotoken_balance += pseudotokens_to_mint;\n delegate_balances.frozen_deposits_pseudotokens += pseudotokens_to_mint} /\\\n invariant3(ctxt)\n*)\nlet mint_pseudotokens ctxt (delegator_balances_before : delegator_balances)\n pseudotokens_to_mint =\n let open Lwt_result_syntax in\n let delegator = delegator_balances_before.delegator in\n let delegate = delegator_balances_before.delegate_balances.delegate in\n let*? new_pseudotoken_balance =\n Staking_pseudotoken_repr.(\n delegator_balances_before.pseudotoken_balance +? pseudotokens_to_mint)\n in\n let*? new_delegate_total_frozen_deposits_pseudotokens =\n Staking_pseudotoken_repr.(\n delegator_balances_before.delegate_balances.frozen_deposits_pseudotokens\n +? pseudotokens_to_mint)\n in\n let*! ctxt =\n Storage.Contract.Staking_pseudotokens.add\n ctxt\n delegator\n new_pseudotoken_balance\n in\n let*! ctxt =\n Storage.Contract.Frozen_deposits_pseudotokens.add\n ctxt\n (Implicit delegate)\n new_delegate_total_frozen_deposits_pseudotokens\n in\n let balance_updates =\n Receipt_repr.\n [\n item\n (Staking_delegator_numerator {delegator})\n (Credited pseudotokens_to_mint)\n Block_application;\n item\n (Staking_delegate_denominator {delegate})\n (Credited pseudotokens_to_mint)\n Block_application;\n ]\n in\n return (ctxt, balance_updates)\n\n(** [burn_pseudotokens ctxt delegator_balances_before\n pseudotokens_to_burn] burns [pseudotokens_to_burn] pseudotokens\n from the balance of [delegator_balances_before.delegator]. Both\n tables are updated to maintain invariant 3.\n\n Precondition:\n unchecked: get_delegator_balances ctxt delegator_balances_before.delegator = return delegator_balances_before /\\\n unchecked: invariant3(ctxt)\n Postcondition:\n get_delegator_balances ctxt delegator_balances_before.delegator =\n return {delegator_balances_before with\n pseudotoken_balance -= pseudotokens_to_mint;\n delegate_balances.frozen_deposits_pseudotokens -= pseudotokens_to_mint} /\\\n invariant3(ctxt)\n*)\nlet burn_pseudotokens ctxt (delegator_balances_before : delegator_balances)\n pseudotokens_to_burn =\n let open Lwt_result_syntax in\n let delegator = delegator_balances_before.delegator in\n let delegate = delegator_balances_before.delegate_balances.delegate in\n let*? new_pseudotoken_balance =\n Staking_pseudotoken_repr.(\n delegator_balances_before.pseudotoken_balance -? pseudotokens_to_burn)\n in\n let*? new_delegate_total_frozen_deposits_pseudotokens =\n Staking_pseudotoken_repr.(\n delegator_balances_before.delegate_balances.frozen_deposits_pseudotokens\n -? pseudotokens_to_burn)\n in\n let*! ctxt =\n Storage.Contract.Staking_pseudotokens.add\n ctxt\n delegator\n new_pseudotoken_balance\n in\n let*! ctxt =\n Storage.Contract.Frozen_deposits_pseudotokens.add\n ctxt\n (Implicit delegate)\n new_delegate_total_frozen_deposits_pseudotokens\n in\n let balance_updates =\n Receipt_repr.\n [\n item\n (Staking_delegate_denominator {delegate})\n (Debited pseudotokens_to_burn)\n Block_application;\n item\n (Staking_delegator_numerator {delegator})\n (Debited pseudotokens_to_burn)\n Block_application;\n ]\n in\n return (ctxt, balance_updates)\n\n(** {0} Conversion between tez and pseudotokens *)\n\n(** Tez -> pseudotokens conversion.\n Precondition:\n tez_amount <> 0 /\\\n delegate_balances.frozen_deposits_pseudotokens <> 0 /\\\n delegate_balances.frozen_deposits_staked_tez <> 0.\n Postcondition:\n result <> 0.\n*)\nlet pseudotokens_of ~rounding (delegate_balances : delegate_balances) tez_amount\n =\n assert (\n Staking_pseudotoken_repr.(\n delegate_balances.frozen_deposits_pseudotokens <> zero)) ;\n assert (Tez_repr.(delegate_balances.frozen_deposits_staked_tez <> zero)) ;\n assert (Tez_repr.(tez_amount <> zero)) ;\n Staking_pseudotoken_repr.mul_ratio\n ~rounding\n delegate_balances.frozen_deposits_pseudotokens\n ~num:(Tez_repr.to_mutez tez_amount)\n ~den:(Tez_repr.to_mutez delegate_balances.frozen_deposits_staked_tez)\n\n(** Pseudotokens -> tez conversion.\n Precondition:\n delegate_balances.frozen_deposits_pseudotokens <> 0.\n*)\nlet tez_of ~rounding (delegate_balances : delegate_balances) pseudotoken_amount\n =\n assert (\n Staking_pseudotoken_repr.(\n delegate_balances.frozen_deposits_pseudotokens <> zero)) ;\n Tez_repr.mul_ratio\n ~rounding\n delegate_balances.frozen_deposits_staked_tez\n ~num:(Staking_pseudotoken_repr.to_int64 pseudotoken_amount)\n ~den:\n (Staking_pseudotoken_repr.to_int64\n delegate_balances.frozen_deposits_pseudotokens)\n\n(** [compute_pseudotoken_credit_for_tez_amount delegate_balances\n tez_amount] is a safe wrapper around [pseudotokens_of\n delegate_balances tez_amount].\n\n Rounding disadvantages newcomer (gets less pseudotokens for the same tez\n value).\n*)\nlet compute_pseudotoken_credit_for_tez_amount delegate_balances tez_amount =\n let open Result_syntax in\n if Tez_repr.(tez_amount = zero) then\n (* This is dead code because Apply.apply_stake already forbids the\n amount=0 case. We keep this dead code here to avoid putting too\n many preconditions on the usage of this module. *)\n return Staking_pseudotoken_repr.zero\n else if\n Staking_pseudotoken_repr.(\n delegate_balances.frozen_deposits_pseudotokens = zero)\n then\n (* Pseudotokens are not yet initialized, the conversion rate is\n 1. *)\n return @@ Staking_pseudotoken_repr.init_of_tez tez_amount\n else if Tez_repr.(delegate_balances.frozen_deposits_staked_tez = zero) then\n (* Can only happen in an attempt to stake after a full\n slashing. We forbid this case to avoid having to iterate over\n all stakers to reset their pseudotoken balances. *)\n tzfail Cannot_stake_on_fully_slashed_delegate\n else pseudotokens_of ~rounding:`Down delegate_balances tez_amount\n\nlet stake ctxt ~delegator ~delegate tez_amount =\n let open Lwt_result_syntax in\n let* delegate_balances = get_delegate_balances ctxt ~delegate in\n let*? pseudotokens_to_credit =\n compute_pseudotoken_credit_for_tez_amount delegate_balances tez_amount\n in\n let* delegator_balances =\n get_delegator_balances ctxt ~delegator ~delegate_balances\n in\n mint_pseudotokens ctxt delegator_balances pseudotokens_to_credit\n\n(** {0} Exported functions, see the mli file. *)\nlet stake ctxt ~contract ~delegate tez_amount =\n if Contract_repr.(contract = Implicit delegate) then\n (* No pseudotokens for delegates. *)\n Lwt_result_syntax.return (ctxt, [])\n else stake ctxt ~delegator:contract ~delegate tez_amount\n\n(*\n Rounding disadvantages unstaker. *)\nlet request_unstake ctxt ~delegator ~delegate requested_amount =\n let open Lwt_result_syntax in\n let* delegate_balances = get_delegate_balances ctxt ~delegate in\n if Tez_repr.(delegate_balances.frozen_deposits_staked_tez = zero) then\n return (ctxt, Tez_repr.zero, [])\n else\n let* delegator_balances =\n get_delegator_balances ctxt ~delegator ~delegate_balances\n in\n if Staking_pseudotoken_repr.(delegator_balances.pseudotoken_balance = zero)\n then return (ctxt, Tez_repr.zero, [])\n else (\n assert (\n Staking_pseudotoken_repr.(\n delegate_balances.frozen_deposits_pseudotokens <> zero)) ;\n\n let*? max_to_request =\n tez_of\n ~rounding:`Down\n delegate_balances\n delegator_balances.pseudotoken_balance\n in\n let requested_amount = Tez_repr.min max_to_request requested_amount in\n let*? requested_pseudotokens =\n pseudotokens_of ~rounding:`Up delegate_balances requested_amount\n in\n let pseudotokens_to_unstake =\n Staking_pseudotoken_repr.min\n requested_pseudotokens\n delegator_balances.pseudotoken_balance\n in\n let*? tez_to_unstake =\n tez_of ~rounding:`Down delegate_balances pseudotokens_to_unstake\n in\n let*? pseudotokens_to_unstake, tez_to_unstake =\n let open Result_syntax in\n if Tez_repr.(tez_to_unstake > requested_amount) then (\n (* this may happen because of the rounding up of pseudotokens, in\n this case we resort to unstaking a bit less *)\n let pseudotokens_to_unstake =\n match Staking_pseudotoken_repr.pred pseudotokens_to_unstake with\n | None -> assert false (* by postcondition of pseudotokens_of *)\n | Some pt -> pt\n in\n let* tez_to_unstake =\n tez_of ~rounding:`Down delegate_balances pseudotokens_to_unstake\n in\n assert (Tez_repr.(tez_to_unstake <= requested_amount)) ;\n return (pseudotokens_to_unstake, tez_to_unstake))\n else return (pseudotokens_to_unstake, tez_to_unstake)\n in\n let+ ctxt, balance_updates =\n burn_pseudotokens ctxt delegator_balances pseudotokens_to_unstake\n in\n (ctxt, tez_to_unstake, balance_updates))\n\nlet request_unstake ctxt ~contract ~delegate requested_amount =\n let open Lwt_result_syntax in\n if Tez_repr.(requested_amount = zero) then return (ctxt, Tez_repr.zero, [])\n else if Contract_repr.(contract = Implicit delegate) then\n let+ delegate_own_frozen_deposits =\n get_own_frozen_deposits ctxt ~delegate\n in\n (ctxt, Tez_repr.min delegate_own_frozen_deposits requested_amount, [])\n else request_unstake ctxt ~delegator:contract ~delegate requested_amount\n\nmodule For_RPC = struct\n let staked_balance ctxt ~delegator ~delegate =\n let open Lwt_result_syntax in\n let* delegate_balances = get_delegate_balances ctxt ~delegate in\n let* delegator_balances =\n get_delegator_balances ctxt ~delegator ~delegate_balances\n in\n if\n Staking_pseudotoken_repr.(\n delegate_balances.frozen_deposits_pseudotokens <> zero)\n then\n Lwt.return\n @@ tez_of\n ~rounding:`Down\n delegate_balances\n delegator_balances.pseudotoken_balance\n else (\n assert (\n Staking_pseudotoken_repr.(delegator_balances.pseudotoken_balance = zero)) ;\n return Tez_repr.zero)\n\n let staked_balance ctxt ~contract ~delegate =\n if Contract_repr.(contract = Implicit delegate) then\n get_own_frozen_deposits ctxt ~delegate\n else staked_balance ctxt ~delegator:contract ~delegate\n\n let staking_pseudotokens_balance = staking_pseudotokens_balance\n\n let get_frozen_deposits_pseudotokens = get_frozen_deposits_pseudotokens\n\n let get_frozen_deposits_staked_tez = get_frozen_deposits_staked_tez\nend\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 implicit or it is (originated 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(** [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\nval get_total_supply : Raw_context.t -> Tez_repr.t tzresult Lwt.t\n\nmodule For_RPC : sig\n val get_staked_balance :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t option tzresult Lwt.t\n\n val get_unstaked_frozen_balance :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t option tzresult Lwt.t\n\n val get_unstaked_finalizable_balance :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t option tzresult Lwt.t\n\n val get_full_balance :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t\nend\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 open Lwt_result_syntax in\n let contract = Contract_repr.Originated contract in\n let* c = Storage.Contract.Spendable_balance.init c contract Tez_repr.zero in\n let {Script_repr.code; storage}, lazy_storage_diff = script in\n let* c, code_size = Storage.Contract.Code.init c contract code in\n let* c, storage_size = Storage.Contract.Storage.init c contract storage in\n let* c, lazy_storage_size = update_script_lazy_storage c lazy_storage_diff in\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 let* c =\n Storage.Contract.Paid_storage_space.init\n c\n contract\n prepaid_bootstrap_storage\n in\n Storage.Contract.Used_storage_space.init c contract total_size\n\nlet create_implicit c manager ~balance =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Implicit manager in\n let* counter = Storage.Contract.Global_counter.get c in\n let* c = Storage.Contract.Counter.init c contract counter in\n let* c = Storage.Contract.Spendable_balance.init c contract balance in\n Contract_manager_storage.init c contract (Manager_repr.Hash manager)\n\nlet delete c contract =\n let open Lwt_result_syntax in\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 let* c = Contract_delegate_storage.unlink c contract in\n let update local =\n let* local =\n Storage.Contract.Spendable_balance.Local.remove_existing local\n in\n let* local = Storage.Contract.Manager.Local.remove_existing local in\n Storage.Contract.Counter.Local.remove_existing local\n in\n let+ c, () =\n Storage.Contract.with_local_context c contract (fun local ->\n let+ local = update local in\n (local, ()))\n in\n 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 let open Lwt_syntax in\n let* exists_contract = exists c contract in\n match exists_contract with\n | true -> return_unit\n | false -> tzfail (Non_existing_contract contract)\n\nlet must_be_allocated c contract =\n let open Lwt_syntax in\n let* is_allocated = allocated c contract in\n match is_allocated with\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 let open Result_syntax in\n let+ c, nonce = Raw_context.increment_origination_nonce c in\n (c, Contract_hash.of_nonce nonce)\n\nlet originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =\n let open Lwt_result_syntax in\n let*? since = Raw_context.get_origination_nonce ctxt_since in\n let*? until = Raw_context.get_origination_nonce ctxt_until in\n let*! result =\n List.filter_s\n (fun contract -> exists ctxt_until (Contract_repr.Originated contract))\n (Contract_repr.originated_contracts ~since ~until)\n in\n return result\n\nlet check_counter_increment c manager counter =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Implicit manager in\n let* contract_counter = Storage.Contract.Counter.get c contract in\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 open Lwt_result_syntax in\n let contract = Contract_repr.Implicit manager in\n let* global_counter = Storage.Contract.Global_counter.get c in\n let* c =\n Storage.Contract.Global_counter.update\n c\n (Manager_counter_repr.succ global_counter)\n in\n let* contract_counter = Storage.Contract.Counter.get c contract in\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 open Lwt_result_syntax in\n let contract = Contract_repr.Originated contract_hash in\n let* c, code = Storage.Contract.Code.find c contract in\n let* c, storage = Storage.Contract.Storage.find c contract in\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 open Lwt_result_syntax in\n let contract = Contract_repr.Originated contract_hash in\n let* result = Storage.Contract.Storage.find ctxt contract in\n match result with\n | ctxt, None -> return (ctxt, None)\n | ctxt, Some storage ->\n let*? ctxt =\n Raw_context.consume_gas ctxt (Script_repr.force_decode_cost storage)\n in\n let*? storage = Script_repr.force_decode storage in\n return (ctxt, Some storage)\n\nlet get_counter c manager =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Implicit manager in\n let* counter_opt = Storage.Contract.Counter.find c contract in\n match counter_opt with\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 let open Lwt_result_syntax in\n let* balance_opt = Storage.Contract.Spendable_balance.find c contract in\n match balance_opt with\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 let open Lwt_result_syntax in\n let*? c =\n Raw_context.consume_gas\n c\n (Storage_costs.read_access ~path_length:4 ~read_bytes:8)\n in\n let* balance = get_balance c contract in\n 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 open Lwt_result_syntax in\n let contract = Contract_repr.Originated contract_hash in\n let storage = Script_repr.lazy_expr storage in\n let* c, lazy_storage_size_diff =\n update_script_lazy_storage c lazy_storage_diff\n in\n let* c, size_diff = Storage.Contract.Storage.update c contract storage in\n let* previous_size = Storage.Contract.Used_storage_space.get c contract in\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 tzfail (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_delegated_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 let open Lwt_result_syntax in\n let* balance_opt = Storage.Contract.Spendable_balance.find c contract in\n match balance_opt with\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 let*? balance = Tez_repr.(amount +? balance) in\n let* c = Storage.Contract.Spendable_balance.update c contract balance in\n Stake_storage.add_contract_delegated_stake c contract amount\n\nlet init c =\n let open Lwt_result_syntax in\n let* c = Storage.Contract.Global_counter.init c Manager_counter_repr.init in\n Lazy_storage_diff.init c\n\nlet used_storage_space c contract =\n let open Lwt_result_syntax in\n let+ value = Storage.Contract.Used_storage_space.find c contract in\n Option.value ~default:Z.zero value\n\nlet paid_storage_space c contract =\n let open Lwt_result_syntax in\n let+ value = Storage.Contract.Paid_storage_space.find c contract in\n Option.value ~default:Z.zero value\n\nlet set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space =\n let open Lwt_result_syntax in\n let* already_paid_space =\n Storage.Contract.Paid_storage_space.get c contract\n in\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 let+ c =\n Storage.Contract.Paid_storage_space.update c contract new_storage_space\n in\n (to_pay, c)\n\nlet increase_paid_storage c contract_hash ~amount_in_bytes:storage_incr =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Originated contract_hash in\n let* already_paid_space =\n Storage.Contract.Paid_storage_space.get c contract\n in\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 get_frozen_bonds ctxt contract =\n let open Lwt_result_syntax in\n let+ value = Storage.Contract.Total_frozen_bonds.find ctxt contract in\n Option.value ~default:Tez_repr.zero value\n\nlet get_balance_and_frozen_bonds ctxt contract =\n let open Lwt_result_syntax in\n let* balance = Storage.Contract.Spendable_balance.get ctxt contract in\n let* total_bonds = get_frozen_bonds ctxt contract in\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 let open Lwt_result_syntax in\n let* () =\n fail_when Tez_repr.(amount = zero) (Failure \"Expecting : [amount > 0]\")\n in\n let* ctxt =\n Stake_storage.remove_contract_delegated_stake ctxt contract amount\n in\n let* ctxt, frozen_bonds =\n Storage.Contract.Frozen_bonds.get (ctxt, contract) bond_id\n in\n let*? () =\n error_when\n Tez_repr.(frozen_bonds <> amount)\n (Frozen_bonds_must_be_spent_at_once (contract, bond_id))\n in\n let* ctxt, _ =\n Storage.Contract.Frozen_bonds.remove_existing (ctxt, contract) bond_id\n in\n let* total = Storage.Contract.Total_frozen_bonds.get ctxt contract in\n let*? new_total = Tez_repr.(total -? amount) in\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 let open Lwt_result_syntax in\n let* () =\n fail_when Tez_repr.(amount = zero) (Failure \"Expecting : [amount > 0]\")\n in\n let* ctxt = Stake_storage.add_contract_delegated_stake ctxt contract amount in\n let* ctxt, _ =\n let* ctxt, frozen_bonds_opt =\n Storage.Contract.Frozen_bonds.find (ctxt, contract) bond_id\n in\n match frozen_bonds_opt with\n | None -> Storage.Contract.Frozen_bonds.init (ctxt, contract) bond_id amount\n | Some frozen_bonds ->\n let*? new_amount = Tez_repr.(frozen_bonds +? amount) in\n Storage.Contract.Frozen_bonds.update (ctxt, contract) bond_id new_amount\n in\n let* total_opt = Storage.Contract.Total_frozen_bonds.find ctxt contract in\n match total_opt with\n | None -> Storage.Contract.Total_frozen_bonds.init ctxt contract amount\n | Some total ->\n let*? new_total = Tez_repr.(total +? amount) in\n Storage.Contract.Total_frozen_bonds.update ctxt contract new_total\n\nlet has_frozen_bonds ctxt contract =\n let open Lwt_result_syntax in\n let*! result = Storage.Contract.Total_frozen_bonds.mem ctxt contract in\n return result\n\nlet has_frozen_deposits ctxt contract =\n let open Lwt_result_syntax in\n let* pseudo = Storage.Contract.Staking_pseudotokens.find ctxt contract in\n match pseudo with\n | Some v when not Staking_pseudotoken_repr.(v = zero) -> return_true\n | _ -> (\n let* requests = Storage.Contract.Unstake_requests.find ctxt contract in\n match requests with\n | None | Some {delegate = _; requests = []} -> return_false\n | Some _ -> return_true)\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 let* has_frozen_deposits = has_frozen_deposits ctxt contract in\n if has_frozen_bonds || has_frozen_deposits then return_true\n else\n (* full balance of contract is zero. *)\n let* delegate_opt = Contract_delegate_storage.find ctxt contract in\n match delegate_opt with\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\nlet get_total_supply ctxt = Storage.Contract.Total_supply.get ctxt\n\nmodule For_RPC = struct\n let get_staked_balance ctxt =\n let open Lwt_result_syntax in\n function\n | Contract_repr.Originated _ -> return_none\n | Implicit _ as contract -> (\n let* delegate_opt = Storage.Contract.Delegate.find ctxt contract in\n match delegate_opt with\n | None -> return_none\n | Some delegate ->\n let* own_frozen_deposits =\n Staking_pseudotokens_storage.For_RPC.staked_balance\n ctxt\n ~delegate\n ~contract\n in\n return (Some own_frozen_deposits))\n\n let get_unstaked_balance ctxt =\n let open Lwt_result_syntax in\n function\n | Contract_repr.Originated _ -> return_none\n | Implicit _ as contract -> (\n let* result =\n Unstake_requests_storage.prepare_finalize_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing:false\n contract\n in\n match result with\n | None -> return_some (Tez_repr.zero, Tez_repr.zero)\n | Some {finalizable; unfinalizable} ->\n let* unfinalizable_requests =\n Unstake_requests_storage.For_RPC\n .apply_slash_to_unstaked_unfinalizable\n ctxt\n unfinalizable\n in\n let*? sum_unfinalizable =\n List.fold_left_e\n (fun acc (_cycle, tz) -> Tez_repr.(acc +? tz))\n Tez_repr.zero\n unfinalizable_requests\n in\n let*? sum_finalizable =\n List.fold_left_e\n (fun acc (_, _cycle, tz) -> Tez_repr.(acc +? tz))\n Tez_repr.zero\n finalizable\n in\n return_some (sum_unfinalizable, sum_finalizable))\n\n let get_unstaked_frozen_balance ctxt contract =\n let open Lwt_result_syntax in\n let* balance_opt = get_unstaked_balance ctxt contract in\n match balance_opt with\n | None -> return_none\n | Some (amount, _) -> return_some amount\n\n let get_unstaked_finalizable_balance ctxt contract =\n let open Lwt_result_syntax in\n let* balance_opt = get_unstaked_balance ctxt contract in\n match balance_opt with\n | None -> return_none\n | Some (_, amount) -> return_some amount\n\n let get_full_balance ctxt contract =\n let open Lwt_result_syntax in\n let* balance_n_frozen = get_balance_and_frozen_bonds ctxt contract in\n let* s = get_staked_balance ctxt contract in\n let staked = Option.value ~default:Tez_repr.zero s in\n let* us = get_unstaked_balance ctxt contract in\n let u_frozen, u_final =\n Option.value ~default:(Tez_repr.zero, Tez_repr.zero) us\n in\n Tez_repr.(\n let*? x = balance_n_frozen +? staked in\n let*? y = u_frozen +? x in\n let*? z = u_final +? y in\n return z)\nend\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 [giver],\n [container], or [receiver] represents a kind of account that holds a given (or\n possibly infinite) amount of tokens.\n\n Tokens can be transferred from a [giver] to a [receiver]. To uniformly handle\n all cases, special constructors of givers and receivers may be used. For\n example, the giver [`Minted] is used to express a transfer of minted tokens\n to a receiver, and the receiver [`Burned] is used to express the action of\n burning a given amount of tokens taken from a giver. 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 For backward compatibility purpose, an ANTI-PATTERN is used to redistribute\n slashing to denunciator; this redistribution technic should not be mimicked\n if it can be avoided (see https://gitlab.com/tezos/tezos/-/issues/4787).\n The anti-pattern works as follows:\n The part of slashed amounts that goes to the author of the denunciation are\n not directly distributed to him. Tokens are transferred to a burning sink,\n then minted from an infinite source ( see `Double_signing_punishments,\n and `Sc_rollup_refutation_rewards ).\n Again, this is an ANTI-PATTERN that should not be mimicked.\n*)\n\n(** [container] is the type of token holders with finite capacity, and whose assets\n are contained in the context. An account may have several token holders,\n that can serve as sources and/or sinks.\n For example, an implicit account [d] serving as a delegate has a token holder\n for its own spendable balance, and another token holder for its frozen deposits.\n*)\n\ntype container =\n [ `Contract of Contract_repr.t\n (** Implicit account's or Originated contract's spendable balance *)\n | `Collected_commitments of Blinded_public_key_hash.t\n (** Pre-funded account waiting for the commited pkh and activation code to\n be revealed to unlock the funds *)\n | `Frozen_deposits of Frozen_staker_repr.t\n (** Frozen tokens of a staker for consensus security deposits. *)\n | `Unstaked_frozen_deposits of Unstaked_frozen_staker_repr.t * Cycle_repr.t\n (** Frozen tokens of a contract that have been unstaked at the\n given cycle. *)\n | `Block_fees (** Current block's fees collection *)\n | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t\n (** Frozen tokens of a contract for bond deposits (currently used by rollups) *)\n ]\n\n(** [infinite_source] defines types of tokens providers which are considered to be\n ** of infinite capacity. *)\ntype infinite_source =\n [ `Invoice\n (** Tokens minted during a protocol upgrade,\n typically to fund the development of some part of the amendment. *)\n | `Bootstrap (** Bootstrap accounts funding *)\n | `Initial_commitments\n (** Funding of Genesis' prefunded accounts requiring an activation *)\n | `Revelation_rewards (** Seed nonce revelation rewards *)\n | `Attesting_rewards (** Consensus attesting rewards *)\n | `Baking_rewards (** Consensus baking fixed rewards *)\n | `Baking_bonuses (** Consensus baking variable bonus *)\n | `Minted (** Generic source for test purpose *)\n | `Liquidity_baking_subsidies (** Subsidy for liquidity-baking contract *)\n | `Sc_rollup_refutation_rewards\n (** Sc_rollup refutation rewards (slashing redistribution) *) ]\n\n(** [giver] is the type of token providers. Token providers that are not\n containers are considered to have infinite capacity. *)\ntype giver = [infinite_source | container]\n\ntype infinite_sink =\n [ `Storage_fees (** Fees burnt to compensate storage usage *)\n | `Double_signing_punishments (** Consensus slashing *)\n | `Lost_attesting_rewards of Signature.Public_key_hash.t * bool * bool\n (** Consensus rewards not distributed because the participation of the delegate was too low. *)\n | `Sc_rollup_refutation_punishments (** Smart rollups refutation slashing *)\n | `Burned (** Generic sink mainly for test purpose *) ]\n\n(** [receiver] is the type of token receivers. Token receivers that are not\n containers are considered to have infinite capacity. *)\ntype receiver = [infinite_sink | container]\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\n This function is only defined on the few cases for which it is\n actually needed. *)\nval balance :\n Raw_context.t ->\n [< `Block_fees | `Collected_commitments of Blinded_public_key_hash.t] ->\n (Raw_context.t * Tez_repr.t) tzresult Lwt.t\n\n(** [transfer_n ?origin ctxt givers receiver] transfers [amount] Tez from [giver] to\n [receiver] for each [(giver, amount)] pair in [givers], and returns a new\n context, and the list of corresponding balance updates. The function behaves\n as though [transfer ?origin ctxt giver receiver amount] was invoked for each pair\n [(giver, amount)] in [givers], however a single balance update is generated\n for the total amount transferred to [receiver].\n When [givers] 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 ([< giver] * Tez_repr.t) list ->\n [< receiver] ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [transfer ?origin ctxt giver receiver amount] transfers [amount] Tez from giver\n [giver] to receiver [receiver], 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 [giver] refers to a contract that is\n not allocated.\n Returns a [Balance_too_low] error if [giver] refers to a contract whose\n balance is less than [amount].\n Returns a [Subtraction_underflow] error if [giver] is\n not a contract and its balance is less than [amount].\n Returns a [Empty_implicit_delegated_contract] error if [giver] 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 [receiver] refers to an originated contract that is not allocated.\n Returns a [Non_existing_contract] error if [amount <> Tez_repr.zero], and\n [receiver] refers to an originated contract that is not allocated.\n Returns a [Addition_overflow] error if [receiver] refers to a receiver whose balance\n is greater than [Int64.max - amount].\n Returns a [Wrong_level] error if [src] or [receiver] refer to a level that is\n not the current level. *)\nval transfer :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n [< giver] ->\n [< receiver] ->\n Tez_repr.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\nmodule Internal_for_tests : sig\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. *)\n val allocated :\n Raw_context.t -> container -> (Raw_context.t * bool) tzresult Lwt.t\n\n type container_with_balance =\n [ `Contract of Contract_repr.t\n | `Collected_commitments of Blinded_public_key_hash.t\n | `Block_fees\n | `Frozen_bonds of Contract_repr.t * Bond_id_repr.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 val balance :\n Raw_context.t ->\n [< container_with_balance] ->\n (Raw_context.t * Tez_repr.t) tzresult Lwt.t\nend\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 | `Frozen_deposits of Frozen_staker_repr.t\n | `Unstaked_frozen_deposits of Unstaked_frozen_staker_repr.t * Cycle_repr.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 | `Attesting_rewards\n | `Baking_rewards\n | `Baking_bonuses\n | `Minted\n | `Liquidity_baking_subsidies\n | `Sc_rollup_refutation_rewards ]\n\ntype giver = [infinite_source | container]\n\ntype infinite_sink =\n [ `Storage_fees\n | `Double_signing_punishments\n | `Lost_attesting_rewards of Signature.Public_key_hash.t * bool * bool\n | `Sc_rollup_refutation_punishments\n | `Burned ]\n\ntype receiver = [infinite_sink | container]\n\nlet balance ctxt stored =\n let open Lwt_result_syntax in\n match stored with\n | `Collected_commitments bpkh ->\n let+ balance = Commitment_storage.committed_amount ctxt bpkh in\n (ctxt, balance)\n | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt)\n\nlet credit ctxt receiver amount origin =\n let open Lwt_result_syntax in\n let open Receipt_repr in\n let+ ctxt, balance =\n match receiver 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_attesting_rewards (d, p, r) -> Lost_attesting_rewards (d, p, r)\n | `Sc_rollup_refutation_punishments ->\n Sc_rollup_refutation_punishments\n | `Burned -> Burned\n in\n let* old_total_supply = Storage.Contract.Total_supply.get ctxt in\n let*? new_total_supply = Tez_repr.(old_total_supply -? amount) in\n let+ ctxt =\n Storage.Contract.Total_supply.update ctxt new_total_supply\n in\n (ctxt, sink)\n | #container as container -> (\n match container with\n | `Contract receiver ->\n let+ ctxt =\n Contract_storage.credit_only_call_from_token ctxt receiver amount\n in\n (ctxt, Contract receiver)\n | `Collected_commitments bpkh ->\n let+ ctxt =\n Commitment_storage.increase_commitment_only_call_from_token\n ctxt\n bpkh\n amount\n in\n (ctxt, Commitments bpkh)\n | `Frozen_deposits staker ->\n let+ ctxt =\n Stake_storage.add_frozen_stake_only_call_from_token\n ctxt\n staker\n amount\n in\n (ctxt, Deposits staker)\n | `Unstaked_frozen_deposits (staker, cycle) ->\n let+ ctxt =\n Unstaked_frozen_deposits_storage.credit_only_call_from_token\n ctxt\n staker\n cycle\n amount\n in\n (ctxt, Unstaked_deposits (staker, cycle))\n | `Block_fees ->\n let*? ctxt =\n Raw_context.credit_collected_fees_only_call_from_token ctxt amount\n in\n return (ctxt, Block_fees)\n | `Frozen_bonds (contract, bond_id) ->\n let* ctxt =\n Contract_storage.credit_bond_only_call_from_token\n ctxt\n contract\n bond_id\n amount\n in\n return (ctxt, Frozen_bonds (contract, bond_id)))\n in\n (ctxt, item balance (Credited amount) origin)\n\nlet spend ctxt giver amount origin =\n let open Lwt_result_syntax in\n let open Receipt_repr in\n let+ ctxt, balance =\n match giver 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 | `Attesting_rewards -> Attesting_rewards\n | `Baking_rewards -> Baking_rewards\n | `Baking_bonuses -> Baking_bonuses\n | `Sc_rollup_refutation_rewards -> Sc_rollup_refutation_rewards\n in\n let* old_total_supply = Storage.Contract.Total_supply.get ctxt in\n let*? new_total_supply = Tez_repr.(old_total_supply +? amount) in\n let+ ctxt =\n Storage.Contract.Total_supply.update ctxt new_total_supply\n in\n (ctxt, src)\n | #container as container -> (\n match container with\n | `Contract giver ->\n let+ ctxt =\n Contract_storage.spend_only_call_from_token ctxt giver amount\n in\n (ctxt, Contract giver)\n | `Collected_commitments bpkh ->\n let+ ctxt =\n Commitment_storage.decrease_commitment_only_call_from_token\n ctxt\n bpkh\n amount\n in\n (ctxt, Commitments bpkh)\n | `Frozen_deposits staker ->\n let+ ctxt =\n Stake_storage.remove_frozen_stake_only_call_from_token\n ctxt\n staker\n amount\n in\n (ctxt, Deposits staker)\n | `Unstaked_frozen_deposits (staker, cycle) ->\n let+ ctxt =\n Unstaked_frozen_deposits_storage.spend_only_call_from_token\n ctxt\n staker\n cycle\n amount\n in\n (ctxt, Unstaked_deposits (staker, cycle))\n | `Block_fees ->\n let*? ctxt =\n Raw_context.spend_collected_fees_only_call_from_token ctxt amount\n in\n return (ctxt, Block_fees)\n | `Frozen_bonds (contract, bond_id) ->\n let* ctxt =\n Contract_storage.spend_bond_only_call_from_token\n ctxt\n contract\n bond_id\n amount\n in\n return (ctxt, Frozen_bonds (contract, bond_id)))\n in\n (ctxt, item balance (Debited amount) origin)\n\nlet transfer_n ?(origin = Receipt_repr.Block_application) ctxt givers receiver =\n let open Lwt_result_syntax in\n let givers = List.filter (fun (_, am) -> Tez_repr.(am <> zero)) givers in\n match givers with\n | [] ->\n (* Avoid accessing context data when there is nothing to transfer. *)\n return (ctxt, [])\n | _ :: _ ->\n (* Withdraw from givers. *)\n let* ctxt, amount, debit_logs =\n List.fold_left_es\n (fun (ctxt, total, debit_logs) (giver, amount) ->\n let* ctxt, debit_log = spend ctxt giver amount origin in\n let*? total = Tez_repr.(amount +? total) in\n return (ctxt, total, debit_log :: debit_logs))\n (ctxt, Tez_repr.zero, [])\n givers\n in\n let* ctxt, credit_log = credit ctxt receiver amount origin in\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 let+ ctxt =\n List.fold_left_es\n (fun ctxt (giver, _amount) ->\n match giver with\n | `Contract contract | `Frozen_bonds (contract, _) ->\n Contract_storage.ensure_deallocated_if_empty ctxt contract\n | #giver -> return ctxt)\n ctxt\n givers\n in\n (* Make sure the order of balance updates is : debit logs in the order of\n of the parameter [givers], 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 giver receiver\n amount =\n transfer_n ~origin ctxt [(giver, amount)] receiver\n\nmodule Internal_for_tests = struct\n let allocated ctxt stored =\n let open Lwt_result_syntax in\n match stored with\n | `Contract contract ->\n let*! allocated = Contract_storage.allocated ctxt contract in\n return (ctxt, allocated)\n | `Collected_commitments bpkh ->\n let*! allocated = Commitment_storage.exists ctxt bpkh in\n return (ctxt, allocated)\n | `Frozen_deposits _ | `Unstaked_frozen_deposits _ | `Block_fees ->\n return (ctxt, true)\n | `Frozen_bonds (contract, bond_id) ->\n Contract_storage.bond_allocated ctxt contract bond_id\n\n type container_with_balance =\n [ `Contract of Contract_repr.t\n | `Collected_commitments of Blinded_public_key_hash.t\n | `Block_fees\n | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ]\n\n let balance ctxt (stored : [< container_with_balance]) =\n let open Lwt_result_syntax in\n match stored with\n | (`Collected_commitments _ | `Block_fees) as stored -> balance ctxt stored\n | `Contract contract ->\n let+ balance = Contract_storage.get_balance ctxt contract in\n (ctxt, balance)\n | `Frozen_bonds (contract, bond_id) ->\n let+ ctxt, balance_opt =\n Contract_storage.find_bond ctxt contract bond_id\n in\n (ctxt, Option.value ~default:Tez_repr.zero balance_opt)\nend\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.giver ->\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.giver ->\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.giver ->\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.giver ->\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.giver ->\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 open Lwt_result_syntax in\n let contract = Contract_repr.Originated contract_hash in\n (* Get the new size of the contract's storage. *)\n let* new_storage_size = Contract_storage.used_storage_space ctxt contract in\n let+ to_be_paid, c =\n Contract_storage.set_paid_storage_space_and_return_fees_to_pay\n ctxt\n contract\n new_storage_size\n in\n (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 open Lwt_result_syntax in\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 let*? to_burn = Tez_repr.(cost_per_byte *? Z.to_int64 consumed) in\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 (let* () = source_must_exist c payer in\n let+ ctxt, balance_updates =\n Token.transfer ~origin c payer `Storage_fees to_burn\n in\n (ctxt, remaining, balance_updates))\n\nlet burn_storage_increase_fees ?(origin = Receipt_repr.Block_application) c\n ~payer amount_in_bytes =\n let open Lwt_result_syntax in\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 let*? to_burn = Tez_repr.(cost_per_byte *? Z.to_int64 amount_in_bytes) in\n (* Burning the fees... *)\n trace\n Cannot_pay_storage_fee\n (let* () = source_must_exist c payer in\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_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 let open Result_syntax in\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 tzfail Storage_limit_too_high\n else return_unit\n" ;
} ;
{ name = "Adaptive_issuance_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 costs for the adaptive issuance operations. *)\n\nval find_delegate_cost : Gas_limit_repr.cost\n\nval allocated_cost : Gas_limit_repr.cost\n\nval stake_cost : Gas_limit_repr.cost\n\nval set_delegate_parameters_cost : Gas_limit_repr.cost\n\nval prepare_finalize_unstake_cost : Gas_limit_repr.cost\n\nval finalize_unstake_and_check_cost : Gas_limit_repr.cost\n\nval request_unstake_cost : Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 find_delegate_cost = 420_000\n\nlet allocated_cost = S.safe_int 210_000\n\nlet stake_cost = S.safe_int (find_delegate_cost + 2_100_000)\n\nlet set_delegate_parameters_cost = S.safe_int (find_delegate_cost + 200_000)\n\nlet prepare_finalize_unstake_cost = S.safe_int 940_000\n\nlet finalize_unstake_and_check_cost = S.safe_int 200_000\n\nlet request_unstake_cost = S.safe_int (find_delegate_cost + 2_300_000)\n\nlet find_delegate_cost = S.safe_int find_delegate_cost\n" ;
} ;
{ name = "Adaptive_issuance_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(** [set_adaptive_issuance_enable ctxt] sets the feature flag in the\n in-memory part of the context if the adaptive issuance feature has\n already launched. This means that the activation vote resulted in\n an approbation from the stakeholders and this happened sufficiently\n long ago. *)\nval set_adaptive_issuance_enable : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** [load_reward_coeff ctxt] loads the current cycle's reward coeff from the\n storage into the context *)\nval load_reward_coeff : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** [update_stored_rewards_at_cycle_end ctxt ~new_cycle] updates\n {!Storage.Issuance_coeff} with a new coefficient that will be applied\n [consensus_rights_delay] cycles after the given [new_cycle]. This new coefficient\n depends on the current {!Storage.Total_supply}, and the total active stake\n for when this coefficient is computed.\n\n This function also removes obsolete values from {!Storage.Issuance_coeff},\n and stores the current cycle's coefficient in the context for faster\n access. *)\nval update_stored_rewards_at_cycle_end :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [init ctxt] adds into the context an adaptive issuance vote EMA\n at 0, and adaptive issuance launch cycle at None. *)\nval init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** [update_ema ctxt ~vote] returns the new context with the new EMA *)\nval update_ema :\n Raw_context.t ->\n vote:Per_block_votes_repr.per_block_vote ->\n (Raw_context.t\n * Cycle_repr.t option\n * Per_block_votes_repr.Adaptive_issuance_launch_EMA.t)\n tzresult\n Lwt.t\n\n(** [launch_cycle ctxt] reads from the context the cycle at which\n the adaptive issuance feature is set to activate.\n\n If this function returns [None], then it means the feature has not been\n voted to be activated (yet). *)\nval launch_cycle : Raw_context.t -> Cycle_repr.t option tzresult Lwt.t\n\nmodule For_RPC : sig\n (** [get_reward_coeff ctxt cycle] reads the reward coeff for the given cycle\n from the storage.\n\n Fails if the given cycle is not between [current_cycle] and\n [current_cycle + consensus_rights_delay].\n\n If adaptive issuance has not been activated,\n then this function returns [Q.one].\n Used only for RPCs. To get the actual rewards, use [Delegate_rewards]. *)\n val get_reward_coeff :\n Raw_context.t -> cycle:Cycle_repr.t -> Q.t tzresult Lwt.t\n\n (** [get_reward_bonus ctxt cycle] reads the reward bonus for the given cycle\n from the storage. If [cycle] is [None], returns 0.\n\n Returns 0 if the given cycle is not between [current_cycle] and\n [current_cycle + consensus_rights_delay].\n\n If adaptive issuance has not been activated,\n then this function returns 0.\n Used only for RPCs. To get the actual rewards, use [Delegate_rewards]. *)\n val get_reward_bonus :\n Raw_context.t ->\n cycle:Cycle_repr.t option ->\n Issuance_bonus_repr.t tzresult Lwt.t\nend\n\nmodule Internal_for_tests : sig\n (** Reward computation functions *)\n val compute_reward_coeff_ratio_without_bonus :\n stake_ratio:Q.t -> issuance_ratio_max:Q.t -> issuance_ratio_min:Q.t -> Q.t\n\n val compute_bonus :\n issuance_ratio_max:Q.t ->\n seconds_per_cycle:int64 ->\n stake_ratio:Q.t ->\n base_reward_coeff_ratio:Q.t ->\n previous_bonus:Issuance_bonus_repr.t ->\n reward_params:Constants_parametric_repr.adaptive_rewards_params ->\n Issuance_bonus_repr.t tzresult\n\n val compute_coeff :\n issuance_ratio_max:Q.t ->\n issuance_ratio_min:Q.t ->\n base_total_issued_per_minute:Tez_repr.t ->\n base_reward_coeff_ratio:Q.t ->\n q_total_supply:Q.t ->\n bonus:Issuance_bonus_repr.t ->\n Q.t\n\n val compute_min :\n reward_params:Constants_parametric_repr.adaptive_rewards_params ->\n launch_cycle:Cycle_repr.t option ->\n new_cycle:Cycle_repr.t ->\n Q.t\n\n val compute_max :\n reward_params:Constants_parametric_repr.adaptive_rewards_params ->\n launch_cycle:Cycle_repr.t option ->\n new_cycle:Cycle_repr.t ->\n Q.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(* Default reward coefficient when AI is not in effect, chosen so that\n rewards * coeff = rewards *)\nlet default_reward = Q.one\n\n(* Default bonus value *)\nlet default_bonus = Issuance_bonus_repr.zero\n\n(* Note: the reward and the bonus values are computed as rationals ([Q.t]) but\n are stored as fixed-point values (see {!Issuance_bonus_repr}) so that the\n stored representation does not grow unboundedly. *)\n\ntype error += Undetermined_issuance_coeff_for_cycle of Cycle_repr.t\n\nlet () =\n let open Data_encoding in\n let undetermined_issuance_coeff_for_cycle_description =\n \"Issuance coefficient is only determined for the current cycle and the \\\n next [consensus_rights_delay] cycles to come. Requested cycle is not in \\\n this window.\"\n in\n register_error_kind\n `Permanent\n ~id:\"undetermined_issuance_coeff_for_cycle\"\n ~title:\"Undetermined issuance coeff for cycle\"\n ~description:undetermined_issuance_coeff_for_cycle_description\n ~pp:(fun ppf cycle ->\n Format.fprintf\n ppf\n \"%s (cycle %a)\"\n undetermined_issuance_coeff_for_cycle_description\n Cycle_repr.pp\n cycle)\n (obj1 (req \"Undetermined_issuance_coeff_for_cycle\" Cycle_repr.encoding))\n (function\n | Undetermined_issuance_coeff_for_cycle cycle -> Some cycle | _ -> None)\n (fun cycle -> Undetermined_issuance_coeff_for_cycle cycle)\n\nlet launch_cycle ctxt = Storage.Adaptive_issuance.Activation.get ctxt\n\nlet check_determined_cycle ctxt cycle =\n let ai_enable = Constants_storage.adaptive_issuance_enable ctxt in\n if ai_enable then\n let ctxt_cycle = (Raw_context.current_level ctxt).cycle in\n let cycles_delay = Constants_storage.issuance_modification_delay ctxt in\n fail_unless\n Cycle_repr.(ctxt_cycle <= cycle && cycle <= add ctxt_cycle cycles_delay)\n (Undetermined_issuance_coeff_for_cycle cycle)\n else return_unit\n\nlet get_reward_coeff ctxt ~cycle =\n let open Lwt_result_syntax in\n let* () = check_determined_cycle ctxt cycle in\n let ai_enable = Constants_storage.adaptive_issuance_enable ctxt in\n if ai_enable then\n (* Even if AI is enabled, the storage can be empty: this is the case for\n the first 5 cycles after AI is enabled *)\n let* k_opt = Storage.Issuance_coeff.find ctxt cycle in\n return (Option.value ~default:default_reward k_opt)\n else return default_reward\n\nlet get_reward_bonus ctxt ~cycle =\n let open Lwt_result_syntax in\n match cycle with\n | None -> return default_bonus\n | Some cycle ->\n let ai_enable = Constants_storage.adaptive_issuance_enable ctxt in\n if ai_enable then\n let* k_opt = Storage.Issuance_bonus.find ctxt cycle in\n return (Option.value ~default:default_bonus k_opt)\n else return default_bonus\n\nlet load_reward_coeff ctxt ~cycle =\n let open Lwt_result_syntax in\n let* new_reward = get_reward_coeff ctxt ~cycle in\n let ctxt =\n Raw_context.update_reward_coeff_for_current_cycle ctxt new_reward\n in\n return ctxt\n\nlet truncate_reward_coeff ~issuance_ratio_min ~issuance_ratio_max f =\n let f = Q.min f issuance_ratio_max in\n let f = Q.max f issuance_ratio_min in\n f\n\nlet compute_extremum ~launch_cycle ~new_cycle ~initial_period ~transition_period\n ~initial ~final =\n match launch_cycle with\n | None ->\n (* This case shouldn't happen, but if it does this value is the most sensible *)\n initial\n | Some launch_cycle ->\n let transition_period = transition_period + 1 in\n assert (Compare.Int.(transition_period > 0)) ;\n let t1 = Cycle_repr.add launch_cycle initial_period in\n let t2 = Cycle_repr.add t1 transition_period in\n if Cycle_repr.(new_cycle <= t1) then initial\n else if Cycle_repr.(new_cycle >= t2) then final\n else\n let t = Cycle_repr.diff new_cycle t1 |> Q.of_int32 in\n Q.(((final - initial) * t / of_int transition_period) + initial)\n\nlet compute_min\n ~(reward_params : Constants_parametric_repr.adaptive_rewards_params) =\n let Constants_parametric_repr.\n {\n initial_period;\n transition_period;\n issuance_ratio_initial_min;\n issuance_ratio_final_min;\n _;\n } =\n reward_params\n in\n compute_extremum\n ~initial_period\n ~transition_period\n ~initial:issuance_ratio_initial_min\n ~final:issuance_ratio_final_min\n\nlet compute_max\n ~(reward_params : Constants_parametric_repr.adaptive_rewards_params) =\n let Constants_parametric_repr.\n {\n initial_period;\n transition_period;\n issuance_ratio_initial_max;\n issuance_ratio_final_max;\n _;\n } =\n reward_params\n in\n compute_extremum\n ~initial_period\n ~transition_period\n ~initial:issuance_ratio_initial_max\n ~final:issuance_ratio_final_max\n\nlet compute_reward_coeff_ratio_without_bonus =\n let q_1600 = Q.of_int 1600 in\n fun ~stake_ratio ~issuance_ratio_max ~issuance_ratio_min ->\n let inv_f = Q.(mul (mul stake_ratio stake_ratio) q_1600) in\n let f = Q.inv inv_f (* f = 1/1600 * (1/x)^2 = yearly issuance rate *) in\n (* f is truncated so that 0.05% <= f <= 5% *)\n truncate_reward_coeff ~issuance_ratio_min ~issuance_ratio_max f\n\nlet compute_bonus ~issuance_ratio_max ~seconds_per_cycle ~stake_ratio\n ~base_reward_coeff_ratio ~(previous_bonus : Issuance_bonus_repr.t)\n ~reward_params =\n let Constants_parametric_repr.\n {\n issuance_ratio_final_min = _;\n issuance_ratio_final_max = _;\n issuance_ratio_initial_min = _;\n issuance_ratio_initial_max = _;\n initial_period = _;\n transition_period = _;\n max_bonus;\n growth_rate;\n center_dz;\n radius_dz;\n } =\n reward_params\n in\n let base_reward_coeff_dist_to_max =\n Q.(issuance_ratio_max - base_reward_coeff_ratio)\n in\n (* The bonus reward is truncated between [0] and [max_bonus] *)\n (* It is done in a way that the bonus does not increase if the coeff\n would already be above the [reward_pct_max] *)\n let max_new_bonus =\n Compare.Q.min base_reward_coeff_dist_to_max (max_bonus :> Q.t)\n in\n (* [dist] is the distance from [stake_ratio] to [48%,52%] *)\n let unsigned_dist =\n Q.(max zero (abs (stake_ratio - center_dz) - radius_dz))\n in\n let q_dist =\n if Compare.Q.(stake_ratio >= center_dz) then Q.neg unsigned_dist\n else unsigned_dist\n in\n let q_seconds_per_cycle = Q.of_int64 seconds_per_cycle in\n let q_days_per_cycle = Q.div q_seconds_per_cycle (Q.of_int 86_400) in\n let q_previous_bonus = (previous_bonus :> Q.t) in\n let new_bonus =\n Q.(add q_previous_bonus (mul q_dist (mul growth_rate q_days_per_cycle)))\n in\n let new_bonus = Q.max new_bonus Q.zero in\n let new_bonus = Q.min new_bonus max_new_bonus in\n Issuance_bonus_repr.of_Q ~max_bonus new_bonus\n\nlet compute_coeff =\n let q_min_per_year = Q.of_int 525600 in\n fun ~issuance_ratio_max\n ~issuance_ratio_min\n ~base_total_issued_per_minute\n ~base_reward_coeff_ratio\n ~q_total_supply\n ~(bonus : Issuance_bonus_repr.t) ->\n if Tez_repr.(base_total_issued_per_minute = zero) then Q.one\n else\n let q_base_total_issued_per_minute =\n Tez_repr.to_mutez base_total_issued_per_minute |> Q.of_int64\n in\n let f = Q.add base_reward_coeff_ratio (bonus :> Q.t) in\n let f = truncate_reward_coeff ~issuance_ratio_min ~issuance_ratio_max f in\n let f = Q.div f q_min_per_year (* = issuance rate per minute *) in\n let f = Q.mul f q_total_supply (* = issuance per minute *) in\n Q.div f q_base_total_issued_per_minute\n\nlet compute_and_store_reward_coeff_at_cycle_end ctxt ~new_cycle =\n let open Lwt_result_syntax in\n let ai_enable = Constants_storage.adaptive_issuance_enable ctxt in\n if not ai_enable then return ctxt\n else\n let* launch_cycle = launch_cycle ctxt in\n let reward_params =\n Constants_storage.adaptive_issuance_rewards_params ctxt\n in\n let modification_delay =\n Constants_storage.issuance_modification_delay ctxt\n in\n let for_cycle = Cycle_repr.add new_cycle modification_delay in\n let before_for_cycle = Cycle_repr.pred for_cycle in\n let* total_supply = Storage.Contract.Total_supply.get ctxt in\n let* total_stake = Stake_storage.get_total_active_stake ctxt for_cycle in\n let base_total_issued_per_minute =\n (Constants_storage.issuance_weights ctxt).base_total_issued_per_minute\n in\n let total_frozen_stake = Stake_repr.get_frozen total_stake in\n let* previous_bonus = get_reward_bonus ctxt ~cycle:before_for_cycle in\n let blocks_per_cycle =\n Constants_storage.blocks_per_cycle ctxt |> Int64.of_int32\n in\n let minimal_block_delay =\n Constants_storage.minimal_block_delay ctxt |> Period_repr.to_seconds\n in\n let seconds_per_cycle = Int64.mul blocks_per_cycle minimal_block_delay in\n let q_total_supply = Tez_repr.to_mutez total_supply |> Q.of_int64 in\n let q_total_frozen_stake =\n Tez_repr.to_mutez total_frozen_stake |> Q.of_int64\n in\n let stake_ratio =\n Q.div q_total_frozen_stake q_total_supply (* = portion of frozen stake *)\n in\n let issuance_ratio_min =\n compute_min ~launch_cycle ~new_cycle ~reward_params\n in\n let issuance_ratio_max =\n compute_max ~launch_cycle ~new_cycle ~reward_params\n in\n let base_reward_coeff_ratio =\n compute_reward_coeff_ratio_without_bonus\n ~stake_ratio\n ~issuance_ratio_max\n ~issuance_ratio_min\n in\n let*? bonus =\n compute_bonus\n ~issuance_ratio_max\n ~seconds_per_cycle\n ~stake_ratio\n ~base_reward_coeff_ratio\n ~previous_bonus\n ~reward_params\n in\n let coeff =\n compute_coeff\n ~issuance_ratio_max\n ~issuance_ratio_min\n ~base_total_issued_per_minute\n ~base_reward_coeff_ratio\n ~q_total_supply\n ~bonus\n in\n let*! ctxt = Storage.Issuance_bonus.add ctxt for_cycle bonus in\n let*! ctxt = Storage.Issuance_coeff.add ctxt for_cycle coeff in\n return ctxt\n\nlet clear_outdated_reward_data ctxt ~new_cycle =\n let open Lwt_syntax in\n match Cycle_repr.sub new_cycle 2 with\n | None -> Lwt.return ctxt\n | Some cycle ->\n let* ctxt = Storage.Issuance_coeff.remove ctxt cycle in\n Storage.Issuance_bonus.remove ctxt cycle\n\nlet update_stored_rewards_at_cycle_end ctxt ~new_cycle =\n let open Lwt_result_syntax in\n let* ctxt = compute_and_store_reward_coeff_at_cycle_end ctxt ~new_cycle in\n let*! ctxt = clear_outdated_reward_data ctxt ~new_cycle in\n load_reward_coeff ctxt ~cycle:new_cycle\n\nlet load_reward_coeff ctxt =\n load_reward_coeff ctxt ~cycle:(Raw_context.current_level ctxt).cycle\n\nlet init ctxt =\n let open Lwt_result_syntax in\n let* ctxt = Storage.Adaptive_issuance.Launch_ema.init ctxt 0l in\n Storage.Adaptive_issuance.Activation.init ctxt None\n\nlet activate ctxt ~cycle =\n Storage.Adaptive_issuance.Activation.update ctxt (Some cycle)\n\nlet set_adaptive_issuance_enable ctxt =\n let open Lwt_result_syntax in\n let+ enable =\n let+ launch_cycle = launch_cycle ctxt in\n match launch_cycle with\n | None -> false\n | Some launch_cycle ->\n let current_cycle = (Level_storage.current ctxt).cycle in\n Cycle_repr.(current_cycle >= launch_cycle)\n in\n if enable then Raw_context.set_adaptive_issuance_enable ctxt else ctxt\n\nlet update_ema ctxt ~vote =\n let open Lwt_result_syntax in\n let* old_ema = Storage.Adaptive_issuance.Launch_ema.get ctxt in\n let* old_ema =\n Per_block_votes_repr.Adaptive_issuance_launch_EMA.of_int32 old_ema\n in\n let new_ema =\n Per_block_votes_repr.compute_new_adaptive_issuance_ema\n ~per_block_vote:vote\n old_ema\n in\n let* ctxt =\n Storage.Adaptive_issuance.Launch_ema.update\n ctxt\n (Per_block_votes_repr.Adaptive_issuance_launch_EMA.to_int32 new_ema)\n in\n let* launch_cycle = launch_cycle ctxt in\n let open Constants_storage in\n let+ ctxt, launch_cycle =\n if\n (not (adaptive_issuance_activation_vote_enable ctxt))\n || Per_block_votes_repr.Adaptive_issuance_launch_EMA.(\n new_ema < adaptive_issuance_launch_ema_threshold ctxt)\n then return (ctxt, launch_cycle)\n else\n match launch_cycle with\n | Some _ ->\n (* the feature is already set to launch, do nothing to avoid postponing it. *)\n return (ctxt, launch_cycle)\n | None ->\n (* set the feature to activate in a few cycles *)\n let current_cycle = (Level_storage.current ctxt).cycle in\n let delay = adaptive_issuance_activation_delay ctxt in\n let cycle = Cycle_repr.add current_cycle delay in\n let+ ctxt = activate ctxt ~cycle in\n (ctxt, Some cycle)\n in\n (ctxt, launch_cycle, new_ema)\n\nmodule For_RPC = struct\n let get_reward_coeff = get_reward_coeff\n\n let get_reward_bonus = get_reward_bonus\nend\n\nmodule Internal_for_tests = struct\n let compute_reward_coeff_ratio_without_bonus =\n compute_reward_coeff_ratio_without_bonus\n\n let compute_bonus = compute_bonus\n\n let compute_coeff = compute_coeff\n\n let compute_min = compute_min\n\n let compute_max = compute_max\nend\n" ;
} ;
{ name = "Delegate_staking_parameters" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 Nomadic Labs *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 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 of_delegate :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Staking_parameters_repr.t tzresult Lwt.t\n\nval pending_updates :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n (Cycle_repr.t * Staking_parameters_repr.t) list tzresult Lwt.t\n\nval register_update :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Staking_parameters_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Maintenance of staking parameters at the beginning of cycle [new_cycle].\n This function iterates on all registered delegates. *)\nval activate : Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 of_delegate ctxt delegate =\n let open Lwt_result_syntax in\n let* t =\n Storage.Contract.Staking_parameters.find\n ctxt\n (Contract_repr.Implicit delegate)\n in\n match t with\n | None -> return Staking_parameters_repr.default\n | Some t -> return t\n\nlet pending_updates ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n let activation_delay =\n Constants_storage.delegate_parameters_activation_delay ctxt\n in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let to_cycle = Cycle_repr.add current_cycle (activation_delay + 1) in\n List.filter_map_es\n (fun cycle ->\n let open Lwt_result_syntax in\n let+ param_opt =\n Storage.Pending_staking_parameters.find (ctxt, cycle) contract\n in\n Option.map (fun param -> (cycle, param)) param_opt)\n Cycle_repr.(current_cycle ---> to_cycle)\n\nlet register_update ctxt delegate t =\n let open Lwt_result_syntax in\n let update_cycle =\n let current_level = Raw_context.current_level ctxt in\n let activation_delay =\n Constants_storage.delegate_parameters_activation_delay ctxt\n in\n Cycle_repr.add current_level.cycle (activation_delay + 1)\n in\n let*! ctxt =\n Storage.Pending_staking_parameters.add\n (ctxt, update_cycle)\n (Contract_repr.Implicit delegate)\n t\n in\n return ctxt\n\nlet activate ctxt ~new_cycle =\n let open Lwt_syntax in\n let* ctxt =\n Storage.Pending_staking_parameters.fold\n (ctxt, new_cycle)\n ~order:`Undefined\n ~init:ctxt\n ~f:(fun delegate t ctxt ->\n Storage.Contract.Staking_parameters.add ctxt delegate t)\n in\n Storage.Pending_staking_parameters.clear (ctxt, new_cycle)\n" ;
} ;
{ name = "Shared_stake" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype shared = {baker_part : Tez_repr.t; stakers_part : Tez_repr.t}\n\n(** [share ~rounding ctxt delegate amount] shares [amount] between a [baker_part] and a\n [stakers_part] proportionally to their shares in [delegate]'s frozen\n deposits.\n [rounding] controls where the extra mutez goes in case the split doesn't\n fall on integer values. *)\nval share :\n rounding:[`Towards_stakers | `Towards_baker] ->\n Raw_context.t ->\n Signature.public_key_hash ->\n Tez_repr.t ->\n shared tzresult Lwt.t\n\n(** [pay_rewards ctxt ?active_stake source delegate] transfers the rewards to the\n [delegate] spendable balance and frozen balance.\n\n The distribution is based on the baker's staking parameters.\n\n If adaptive issuance is enabled, it also accounts for the repartition of the\n delegate's [active_stake] between delegated token and frozen deposits.\n If [active_stake] is not provided, it will be retrieved from the context.\n*)\nval pay_rewards :\n Raw_context.t ->\n ?active_stake:Stake_repr.t ->\n source:[< Token.giver] ->\n delegate:Signature.public_key_hash ->\n Tez_repr.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\ntype shared = {baker_part : Tez_repr.t; stakers_part : Tez_repr.t}\n\nlet share ~adaptive_issuance_global_limit_of_staking_over_baking\n (delegate_parameters : Staking_parameters_repr.t) ~rounding\n ~full_staking_balance amount =\n let open Result_syntax in\n let num, den =\n Full_staking_balance_repr.own_ratio\n ~adaptive_issuance_global_limit_of_staking_over_baking\n ~delegate_limit_of_staking_over_baking_millionth:\n delegate_parameters.limit_of_staking_over_baking_millionth\n full_staking_balance\n in\n let* baker_part =\n let rounding =\n match rounding with `Towards_stakers -> `Down | `Towards_baker -> `Up\n in\n Tez_repr.mul_ratio ~rounding amount ~num ~den\n in\n let* stakers_part = Tez_repr.(amount -? baker_part) in\n return {baker_part; stakers_part}\n\ntype reward_distrib = {\n to_baker_from_staking : Tez_repr.t;\n to_baker_from_edge_over_stakers : Tez_repr.t;\n to_stakers : Tez_repr.t;\n to_spendable : Tez_repr.t;\n}\n\n(** Compute the reward distribution between frozen and spendable according to:\n - the [full_staking_balance] of the delegate composed of the [own_frozen]\n and [staked_frozen] parts (the delegated part is ignored).\n - the [stake] of the delegate composed of the [frozen] deposits and the\n [weighted_delegated] tokens.\n - the [edge_of_baking_over_staking_billionth] parameter set by the baker in 1_000_000_000th\n - the [rewards] to be distributed\n\nPreconditions:\n - 0 <= [edge_of_baking_over_staking_billionth] <= 1_000_000_000\n\nRounding favors:\n - staking over delegation\n - baking over staking\n\nIn case the delegate's stake is zero, everything goes to the spendable balance.\n*)\nlet compute_reward_distrib\n ~adaptive_issuance_global_limit_of_staking_over_baking delegate_parameters\n ~full_staking_balance ~stake ~(rewards : Tez_repr.t) =\n let open Result_syntax in\n let ({frozen; weighted_delegated} : Stake_repr.t) = stake in\n let* total_stake = Tez_repr.(frozen +? weighted_delegated) in\n if Tez_repr.(total_stake <= zero) then\n return\n {\n to_spendable = rewards;\n to_baker_from_staking = Tez_repr.zero;\n to_baker_from_edge_over_stakers = Tez_repr.zero;\n to_stakers = Tez_repr.zero;\n }\n else\n let* to_spendable =\n Tez_repr.mul_ratio\n ~rounding:`Down\n rewards\n ~num:(Tez_repr.to_mutez weighted_delegated)\n ~den:(Tez_repr.to_mutez total_stake)\n in\n let* to_frozen = Tez_repr.(rewards -? to_spendable) in\n let* {baker_part; stakers_part} =\n share\n ~adaptive_issuance_global_limit_of_staking_over_baking\n delegate_parameters\n ~rounding:`Towards_baker\n ~full_staking_balance\n to_frozen\n in\n let to_baker_from_staking = baker_part in\n let* to_baker_from_edge_over_stakers =\n Tez_repr.mul_ratio\n ~rounding:`Up\n stakers_part\n ~num:\n (Int64.of_int32\n delegate_parameters.edge_of_baking_over_staking_billionth)\n ~den:1_000_000_000L\n in\n let* to_stakers =\n Tez_repr.(stakers_part -? to_baker_from_edge_over_stakers)\n in\n return\n {\n to_baker_from_staking;\n to_baker_from_edge_over_stakers;\n to_stakers;\n to_spendable;\n }\n\nlet share ~rounding ctxt delegate amount =\n let open Lwt_result_syntax in\n let* delegate_parameters =\n Delegate_staking_parameters.of_delegate ctxt delegate\n in\n let* full_staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n Lwt.return\n (share\n ~adaptive_issuance_global_limit_of_staking_over_baking:\n (Constants_storage\n .adaptive_issuance_global_limit_of_staking_over_baking\n ctxt)\n delegate_parameters\n ~rounding\n ~full_staking_balance\n amount)\n\nlet compute_reward_distrib ctxt delegate stake rewards =\n let open Lwt_result_syntax in\n let* (delegate_parameters : Staking_parameters_repr.t) =\n Delegate_staking_parameters.of_delegate ctxt delegate\n in\n let* full_staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n Lwt.return\n @@ compute_reward_distrib\n ~adaptive_issuance_global_limit_of_staking_over_baking:\n (Constants_storage\n .adaptive_issuance_global_limit_of_staking_over_baking\n ctxt)\n delegate_parameters\n ~full_staking_balance\n ~stake\n ~rewards\n\nlet pay_rewards ctxt ?active_stake ~source ~delegate rewards =\n let open Lwt_result_syntax in\n let* active_stake =\n match active_stake with\n | Some active_stake -> return active_stake\n | None ->\n let*? stake_distrib =\n Raw_context.stake_distribution_for_current_cycle ctxt\n in\n return\n (Option.value\n (Signature.Public_key_hash.Map.find delegate stake_distrib)\n ~default:Stake_repr.zero)\n in\n let* {\n to_baker_from_staking;\n to_baker_from_edge_over_stakers;\n to_stakers;\n to_spendable;\n } =\n compute_reward_distrib ctxt delegate active_stake rewards\n in\n let* ctxt, balance_updates_frozen_rewards_baker =\n Token.transfer\n ctxt\n source\n (`Frozen_deposits (Frozen_staker_repr.baker delegate))\n to_baker_from_staking\n in\n let* ctxt, balance_updates_frozen_rewards_baker_edge =\n Token.transfer\n ctxt\n source\n (`Frozen_deposits (Frozen_staker_repr.baker_edge delegate))\n to_baker_from_edge_over_stakers\n in\n let* ctxt, balance_updates_frozen_rewards_stakers =\n Token.transfer\n ctxt\n source\n (`Frozen_deposits (Frozen_staker_repr.shared_between_stakers ~delegate))\n to_stakers\n in\n let+ ctxt, balance_updates_spendable_rewards =\n Token.transfer\n ctxt\n source\n (`Contract (Contract_repr.Implicit delegate))\n to_spendable\n in\n ( ctxt,\n balance_updates_frozen_rewards_baker\n @ balance_updates_frozen_rewards_baker_edge\n @ balance_updates_frozen_rewards_stakers @ balance_updates_spendable_rewards\n )\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 * Signature.Public_key.t) list\n tzresult\n 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]. *)\nval activate : Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t 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 + consensus_rights_delay + 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 =\n let open Result_syntax in\n function\n | Bls pk -> tzfail (Invalid_consensus_key_update_tz4 pk)\n | Ed25519 _ | Secp256k1 _ | P256 _ -> return_unit\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 ?up_to_cycle delegate =\n let open Lwt_result_syntax in\n let relevant_cycles =\n let level = Raw_context.current_level ctxt in\n let first_cycle = Cycle_repr.succ level.cycle in\n let last_cycle =\n match up_to_cycle with\n | None ->\n let cycles_delay =\n Constants_storage.consensus_key_activation_delay ctxt\n in\n Cycle_repr.add first_cycle cycles_delay\n | Some cycle -> cycle\n in\n Cycle_repr.(first_cycle ---> last_cycle)\n in\n let delegate = Contract_repr.Implicit delegate in\n List.filter_map_es\n (fun cycle ->\n let* pending_for_cycle =\n Storage.Pending_consensus_keys.find (ctxt, cycle) delegate\n in\n pending_for_cycle |> Option.map (fun pk -> (cycle, pk)) |> return)\n relevant_cycles\n\nlet pending_updates ctxt delegate =\n let open Lwt_result_syntax in\n let* updates = raw_pending_updates ctxt delegate in\n return\n (List.map (fun (c, pk) -> (c, Signature.Public_key.hash pk, 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 ~up_to_cycle:cycle delegate in\n let* active = active_pubkey ctxt delegate in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n match List.hd (List.rev pendings) with\n | None -> return (current_cycle, active.consensus_pk)\n | Some (cycle, pk) -> return (cycle, pk)\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 {\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 cycles_delay = Constants_storage.consensus_key_activation_delay ctxt in\n Cycle_repr.add current_level.cycle (cycles_delay + 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.Pending_consensus_keys.add\n (ctxt, update_cycle)\n (Contract_repr.Implicit delegate)\n pk\n in\n return ctxt\n\nlet activate ctxt ~new_cycle =\n let open Lwt_syntax in\n let* ctxt =\n Storage.Pending_consensus_keys.fold\n (ctxt, new_cycle)\n ~order:`Undefined\n ~init:ctxt\n ~f:(fun delegate pk ctxt ->\n Storage.Contract.Consensus_key.add ctxt delegate pk)\n in\n Storage.Pending_consensus_keys.clear (ctxt, new_cycle)\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\n(** Returns a delegate's initial frozen deposits at the beginning of cycle. *)\nval initial_frozen_deposits :\n Raw_context.t -> Signature.public_key_hash -> Tez_repr.t tzresult Lwt.t\n\n(** Returns a delegate's initial frozen deposits at the beginning of the\n previous cycle.\n\n Fails with [No_previous_cycle] if there is no previous cycle. *)\nval initial_frozen_deposits_of_previous_cycle :\n Raw_context.t -> Signature.public_key_hash -> Tez_repr.t tzresult Lwt.t\n\n(** Returns a delegate's current frozen deposits, which is the sum of\n their own frozen funds and those of their stakers if applicable. *)\nval current_frozen_deposits :\n Raw_context.t -> Signature.public_key_hash -> Tez_repr.t tzresult 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\nval spendable_balance :\n Raw_context.t -> Signature.public_key_hash -> 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\n(** The functions in this module are considered too costly to be used in\n the protocol.\n They are meant to be used only to answer RPC calls.\n*)\nmodule For_RPC : sig\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 part of the frozen deposits\n (given by [frozen_deposits]) that belongs to the delegate.\n\n Only use this function for RPCs: this is expensive. *)\n val 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. *)\n val delegated_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\n val staking_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\n val min_delegated_in_current_cycle :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n (Tez_repr.t * Level_repr.t option) tzresult Lwt.t\nend\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\n(*\n Some invariants:\n\n A contract is a delegate <=>\n - it is registered (i.e. in the set {!Storage.Delegates.mem}), and\n - its full staking balance is initialized.\n\n If a contract is a delegate then :\n - it has no stake in another account, though it may (still) have unstake\n requests from another contract.\n\n If a contract is not a delegate then:\n - it has no *own* frozen stake (a.k.a. frozen deposits),\n - it has no consensus key.\n\n Once a contract has become a delegate, it is so forever. There are no ways\n to unregister.\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\ntype error += No_previous_cycle\n\nlet registered = Storage.Delegates.mem\n\nmodule Contract = struct\n let init ctxt contract delegate =\n let open Lwt_result_syntax in\n let* known_delegate =\n Contract_manager_storage.is_manager_key_revealed ctxt delegate\n in\n let*? () = error_unless known_delegate (Unregistered_delegate delegate) in\n let*! is_registered = registered ctxt delegate in\n let*? () = error_unless is_registered (Unregistered_delegate delegate) in\n let* ctxt = Contract_delegate_storage.init ctxt contract delegate in\n let* balance_and_frozen_bonds =\n Contract_storage.get_balance_and_frozen_bonds ctxt contract\n in\n Stake_storage.add_delegated_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_delegated_stake\n c\n contract\n balance_and_frozen_bonds\n in\n let* c = Contract_delegate_storage.set c contract delegate in\n let* c =\n (* Initializes the full staking balance of [delegate]. *)\n Stake_storage.initialize_delegate\n c\n delegate\n ~delegated:balance_and_frozen_bonds\n 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_delegated_stake\n c\n contract\n 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 =\n Stake_storage.add_delegated_stake c delegate balance_and_frozen_bonds\n 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 initial_frozen_deposits ctxt delegate =\n let open Lwt_result_syntax in\n let* stake_opt =\n match Raw_context.find_stake_distribution_for_current_cycle ctxt with\n | Some distribution ->\n return (Signature.Public_key_hash.Map.find delegate distribution)\n | None ->\n (* This branch happens when the stake distribution is not initialized in\n [ctxt], e.g. when RPCs are called or operations are simulated. *)\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let+ stakes =\n Stake_storage.get_selected_distribution ctxt current_cycle\n in\n List.assoc ~equal:Signature.Public_key_hash.equal delegate stakes\n in\n match stake_opt with\n | None -> return Tez_repr.zero\n | Some {frozen; weighted_delegated = _} -> return frozen\n\nlet initial_frozen_deposits_of_previous_cycle ctxt delegate =\n let open Lwt_result_syntax in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n match Cycle_repr.pred current_cycle with\n | None -> tzfail No_previous_cycle\n | Some previous_cycle -> (\n let+ stakes =\n Stake_storage.get_selected_distribution ctxt previous_cycle\n in\n match\n List.assoc ~equal:Signature.Public_key_hash.equal delegate stakes\n with\n | None -> Tez_repr.zero\n | Some {frozen; weighted_delegated = _} -> frozen)\n\nlet current_frozen_deposits ctxt delegate =\n let open Lwt_result_syntax in\n let* full_staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n Lwt.return (Full_staking_balance_repr.total_frozen full_staking_balance)\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 spendable_balance ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Spendable_balance.get ctxt contract\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\nmodule For_RPC = struct\n let full_balance ctxt delegate =\n let open Lwt_result_syntax in\n let* own_frozen_deposits =\n Staking_pseudotokens_storage.For_RPC.staked_balance\n ctxt\n ~delegate\n ~contract:(Contract_repr.Implicit delegate)\n in\n let* unstaked_frozen =\n let* result =\n Unstake_requests_storage.prepare_finalize_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing:false\n (Contract_repr.Implicit delegate)\n in\n match result with\n | None -> return Tez_repr.zero\n | Some {finalizable; unfinalizable} ->\n let* unfinalizable_requests =\n Unstake_requests_storage.For_RPC\n .apply_slash_to_unstaked_unfinalizable\n ctxt\n unfinalizable\n in\n let*? sum_unfinalizable =\n List.fold_left_e\n (fun acc (_cycle, tz) -> Tez_repr.(acc +? tz))\n Tez_repr.zero\n unfinalizable_requests\n in\n let*? sum =\n List.fold_left_e\n (fun acc (_, _cycle, tz) -> Tez_repr.(acc +? tz))\n sum_unfinalizable\n finalizable\n in\n return sum\n in\n let*? all_frozen = Tez_repr.(own_frozen_deposits +? unstaked_frozen) in\n let delegate_contract = Contract_repr.Implicit delegate in\n let* balance_and_frozen_bonds =\n Contract_storage.get_balance_and_frozen_bonds ctxt delegate_contract\n in\n let*? sum = Tez_repr.(all_frozen +? balance_and_frozen_bonds) in\n return sum\n\n let staking_balance ctxt delegate =\n let open Lwt_result_syntax in\n let*! is_registered = registered ctxt delegate in\n if is_registered then\n Stake_storage.For_RPC.get_staking_balance ctxt delegate\n else return Tez_repr.zero\n\n let min_delegated_in_current_cycle ctxt delegate =\n let open Lwt_result_syntax in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let*! is_registered = registered ctxt delegate in\n if is_registered then\n let+ staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n let min_delegated =\n Full_staking_balance_repr.min_delegated_in_cycle\n ~current_cycle\n staking_balance\n in\n let level_of_min_delegated =\n match\n Full_staking_balance_repr.Internal_for_tests_and_RPCs\n .level_of_min_delegated\n staking_balance\n with\n | None -> None\n | Some level ->\n if Cycle_repr.(level.cycle < current_cycle) then None\n else Some level\n in\n (min_delegated, level_of_min_delegated)\n else return (Tez_repr.zero, None)\n\n let delegated_balance ctxt delegate =\n let open Lwt_result_syntax in\n let* staking_balance = staking_balance ctxt delegate in\n let* self_staking_balance = full_balance ctxt delegate in\n let*? sum = Tez_repr.(staking_balance -? self_staking_balance) in\n return sum\nend\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 only delegates associated with\n slots.\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(** [load_sampler_for_cycle ctxt cycle] caches the seeded stake\n sampler for [cycle] in [ctxt]. If the sampler was already cached,\n then [ctxt] is returned unchanged.\n\n This function has the same effect on [ctxt] as {!slot_owner} and\n {!baking_rights_owner}. *)\nval load_sampler_for_cycle :\n Raw_context.t -> Cycle_repr.t -> Raw_context.t 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\nval cleanup_values_for_protocol_p :\n Raw_context.t ->\n preserved_cycles:int ->\n consensus_rights_delay:int ->\n new_cycle:Cycle_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [attesting_rights_count ctxt level] returns a map of the delegates to\n their number of attestation slots for the given level. Fails if the\n given level is in a cycle for which the seed is not in the storage *)\nval attesting_rights_count :\n Raw_context.t ->\n Level_repr.t ->\n (Raw_context.t * int Signature.Public_key_hash.Map.t) tzresult Lwt.t\n\nmodule For_RPC : sig\n (** The baking power for a given delegate computed from its current\n stake. *)\n val delegate_current_baking_power :\n Raw_context.t -> Signature.public_key_hash -> int64 tzresult Lwt.t\nend\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 open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let* ctxt = Storage.Delegate_sampler_state.init ctxt cycle sampler_state in\n let size = 1 (* that's symbolic: 1 cycle = 1 entry *) in\n let*? ctxt = Cache.update ctxt id (Some (sampler_state, size)) in\n return ctxt\n\n let get ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let* v_opt = Cache.find ctxt id in\n match v_opt with\n | None -> Storage.Delegate_sampler_state.get ctxt cycle\n | Some v -> return v\n\n let remove_existing ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let*? ctxt = Cache.update ctxt id None in\n Storage.Delegate_sampler_state.remove_existing ctxt cycle\n\n let remove ctxt cycle =\n let open Lwt_result_syntax in\n let id = identifier_of_cycle cycle in\n let*? ctxt = Cache.update ctxt id None in\n let*! ctxt = Storage.Delegate_sampler_state.remove ctxt cycle in\n return ctxt\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 open Lwt_result_syntax in\n let read ctxt =\n let* seed = Seed_storage.for_cycle ctxt cycle in\n let+ state = Delegate_sampler_state.get ctxt cycle in\n (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 open Lwt_result_syntax in\n let cycle = level.Level_repr.cycle in\n let* c, seed, state = sampler_for_cycle c cycle in\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 let open Lwt_result_syntax in\n let*? round = Round_repr.to_int round in\n let consensus_committee_size = Constants_storage.consensus_committee_size c in\n let*? slot = Slot_repr.of_int (round mod consensus_committee_size) in\n let+ ctxt, pk = slot_owner c level slot in\n (ctxt, slot, pk)\n\nlet load_sampler_for_cycle ctxt cycle =\n let open Lwt_result_syntax in\n let* ctxt, (_ : Seed_repr.seed), (_ : Raw_context.consensus_pk Sampler.t) =\n Random.sampler_for_cycle ctxt cycle\n in\n return ctxt\n\nlet get_delegate_stake_from_staking_balance ctxt delegate staking_balance =\n let open Lwt_result_syntax in\n let* staking_parameters =\n Delegate_staking_parameters.of_delegate ctxt delegate\n in\n Lwt.return\n (Stake_context.apply_limits ctxt staking_parameters staking_balance)\n\nlet get_stakes ctxt =\n let open Lwt_result_syntax in\n let minimal_frozen_stake = Constants_storage.minimal_frozen_stake ctxt in\n let minimal_stake = Constants_storage.minimal_stake ctxt in\n Stake_storage.fold_on_active_delegates_with_minimal_stake_es\n ctxt\n ~order:`Sorted\n ~f:(fun delegate acc ->\n let* staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n (* This function is called after slashing has been applied at cycle end,\n hence there is no need to apply slashing on [staking_balance] as it\n used to be when the value was taken from a snapshot. *)\n if\n Full_staking_balance_repr.has_minimal_frozen_stake\n ~minimal_frozen_stake\n staking_balance\n then\n let* stake_for_cycle =\n get_delegate_stake_from_staking_balance ctxt delegate staking_balance\n in\n if\n Stake_repr.has_minimal_stake_to_participate\n ~minimal_stake\n stake_for_cycle\n then\n let stakes, total_stake = acc in\n let*? total_stake = Stake_repr.(total_stake +? stake_for_cycle) in\n return ((delegate, stake_for_cycle) :: stakes, total_stake)\n else return acc\n else return acc)\n ~init:([], Stake_repr.zero)\n\nlet select_distribution_for_cycle ctxt cycle =\n let open Lwt_result_syntax in\n let* seed = Seed_storage.raw_for_cycle ctxt cycle in\n let* stakes, total_stake = get_stakes ctxt in\n let* ctxt =\n Stake_storage.set_selected_distribution_for_cycle\n ctxt\n cycle\n stakes\n total_stake\n in\n let* stakes_pk =\n List.fold_left_es\n (fun acc (pkh, stake) ->\n let+ pk =\n Delegate_consensus_key.active_pubkey_for_cycle ctxt pkh cycle\n in\n (pk, Stake_repr.staking_weight stake) :: acc)\n []\n stakes\n in\n let state = Sampler.create stakes_pk in\n let* ctxt = Delegate_sampler_state.init ctxt cycle state in\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 consensus_rights_delay = Constants_storage.consensus_rights_delay ctxt in\n let for_cycle = Cycle_repr.add new_cycle consensus_rights_delay in\n select_distribution_for_cycle ctxt for_cycle\n\nlet clear_outdated_sampling_data ctxt ~new_cycle =\n let open Lwt_result_syntax in\n match Cycle_repr.sub new_cycle Constants_repr.max_slashing_period with\n | None -> return ctxt\n | Some outdated_cycle ->\n let* ctxt = Delegate_sampler_state.remove_existing ctxt outdated_cycle in\n Seed_storage.remove_for_cycle ctxt outdated_cycle\n\nlet cleanup_values_for_protocol_p ctxt ~preserved_cycles ~consensus_rights_delay\n ~new_cycle =\n let open Lwt_result_syntax in\n assert (Compare.Int.(consensus_rights_delay <= preserved_cycles)) ;\n if Compare.Int.(consensus_rights_delay = preserved_cycles) then return ctxt\n else\n let start_cycle = Cycle_repr.add new_cycle (consensus_rights_delay + 1) in\n let end_cycle = Cycle_repr.add new_cycle preserved_cycles in\n List.fold_left_es\n Delegate_sampler_state.remove\n ctxt\n Cycle_repr.(start_cycle ---> end_cycle)\n\nlet attesting_rights_count ctxt level =\n let consensus_committee_size =\n Constants_storage.consensus_committee_size ctxt\n in\n let open Lwt_result_syntax in\n let*? slots = Slot_repr.Range.create ~min:0 ~count:consensus_committee_size in\n Slot_repr.Range.fold_es\n (fun (ctxt, map) slot ->\n let* ctxt, consensus_pk = slot_owner ctxt level slot in\n let map =\n Signature.Public_key_hash.Map.update\n consensus_pk.delegate\n (function None -> Some 1 | Some slots_n -> Some (slots_n + 1))\n map\n in\n return (ctxt, map))\n (ctxt, Signature.Public_key_hash.Map.empty)\n slots\n\nmodule For_RPC = struct\n let delegate_current_baking_power ctxt delegate =\n let open Lwt_result_syntax in\n let* stake = Storage.Stake.Staking_balance.get ctxt delegate in\n let* staking_parameters =\n Delegate_staking_parameters.of_delegate ctxt delegate\n in\n Lwt.return @@ Stake_context.baking_weight ctxt staking_parameters stake\nend\n" ;
} ;
{ name = "Delegate_rewards" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 functions return the amount of tez rewarded for each action *)\n\nval baking_reward_fixed_portion : Raw_context.t -> Tez_repr.t tzresult\n\nval baking_reward_bonus_per_slot : Raw_context.t -> Tez_repr.t tzresult\n\nval attesting_reward_per_slot : Raw_context.t -> Tez_repr.t tzresult\n\nval liquidity_baking_subsidy : Raw_context.t -> Tez_repr.t tzresult\n\nval seed_nonce_revelation_tip : Raw_context.t -> Tez_repr.t tzresult\n\nval vdf_revelation_tip : Raw_context.t -> Tez_repr.t tzresult\n\nmodule For_RPC : sig\n type reward_kind =\n | Baking_reward_fixed_portion\n | Baking_reward_bonus_per_slot\n | Attesting_reward_per_slot\n | Seed_nonce_revelation_tip\n | Vdf_revelation_tip\n\n (** [reward_from_constants ~coeff csts ~reward_kind] returns the amount of\n rewards in {!Tez_repr.t} for the given [reward_kind], according to the\n given parameters in [csts]. The (optional) value [coeff] is a\n multiplicative factor applied to the rewards (default = 1).\n It verifies [reward_from_constants ~coeff csts ~reward_kind =\n coeff * reward_from_constants csts ~reward_kind].*)\n val reward_from_constants :\n ?coeff:Q.t ->\n Constants_parametric_repr.t ->\n reward_kind:reward_kind ->\n Tez_repr.t tzresult\n\n val liquidity_baking_subsidy_from_constants :\n Constants_parametric_repr.t -> Tez_repr.t tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(* Sum weights for normalizing *)\nlet sum_weights\n ({\n base_total_issued_per_minute = _;\n baking_reward_fixed_portion_weight;\n baking_reward_bonus_weight;\n attesting_reward_weight;\n seed_nonce_revelation_tip_weight;\n vdf_revelation_tip_weight;\n } :\n Constants_parametric_repr.issuance_weights) =\n let r = baking_reward_fixed_portion_weight in\n let r = baking_reward_bonus_weight + r in\n let r = attesting_reward_weight + r in\n let r = seed_nonce_revelation_tip_weight + r in\n let r = vdf_revelation_tip_weight + r in\n assert (Compare.Int.(r > 0)) ;\n r\n\n(* [tez_from_weights] returns an amount of rewards in [Tez.t],\n given a couple of parameters:\n [rewards] describes all the possible rewards, as a record of weights\n for each of them. It also gives the (maximum) amount of rewards per minute\n expected on the chain\n [weight] is one of those reward weights as described in [rewards]\n [minimal_block_delay] is the minimum amount of time between two blocks. *)\nlet tez_from_weights\n ~(issuance_weights : Constants_parametric_repr.issuance_weights)\n ~(weight : int) ~(minimal_block_delay : Period_repr.t) =\n let sum_weights = sum_weights issuance_weights in\n let block_delay = minimal_block_delay |> Period_repr.to_seconds in\n (* base_tez = issuance_weights.base_total_issued_per_minute\n relative_weight = reward_weight / sum_weights\n minute_per_block = block_delay (in seconds) / 60\n rewarded_tez = base_tez * relative_weight * blocks_per_minute *)\n let num = Int64.(mul (of_int weight) block_delay) in\n let den = Int64.of_int (sum_weights * 60) in\n Tez_repr.mul_ratio\n ~rounding:`Down\n issuance_weights.base_total_issued_per_minute\n ~num\n ~den\n\n(* Bundling some functions inside a module so they can be exported as part\n of `Internal_for_tests` further down. *)\nmodule M = struct\n type reward_kind =\n | Baking_reward_fixed_portion\n | Baking_reward_bonus_per_slot\n | Attesting_reward_per_slot\n | Seed_nonce_revelation_tip\n | Vdf_revelation_tip\n\n let reward_from_constants ~(csts : Constants_parametric_repr.t) ~reward_kind\n ~(coeff : Q.t) =\n let open Result_syntax in\n let issuance_weights = csts.issuance_weights in\n let weight =\n match reward_kind with\n | Baking_reward_fixed_portion ->\n issuance_weights.baking_reward_fixed_portion_weight\n | Baking_reward_bonus_per_slot ->\n issuance_weights.baking_reward_bonus_weight\n | Attesting_reward_per_slot -> issuance_weights.attesting_reward_weight\n | Seed_nonce_revelation_tip ->\n (* Seed nonce revelation rewards are given every [blocks_per_commitment](=192)th block *)\n let blocks_per_commitment = Int32.to_int csts.blocks_per_commitment in\n issuance_weights.seed_nonce_revelation_tip_weight\n * blocks_per_commitment\n | Vdf_revelation_tip ->\n (* Vdf revelation rewards are given every [blocks_per_commitment](=192)th block *)\n let blocks_per_commitment = Int32.to_int csts.blocks_per_commitment in\n issuance_weights.vdf_revelation_tip_weight * blocks_per_commitment\n in\n let minimal_block_delay = csts.minimal_block_delay in\n let* rewards =\n tez_from_weights ~issuance_weights ~weight ~minimal_block_delay\n in\n let base_rewards =\n match reward_kind with\n | Baking_reward_bonus_per_slot ->\n let bonus_committee_size =\n csts.consensus_committee_size - csts.consensus_threshold\n in\n if Compare.Int.(bonus_committee_size <= 0) then Tez_repr.zero\n else Tez_repr.div_exn rewards bonus_committee_size\n | Attesting_reward_per_slot ->\n Tez_repr.div_exn rewards csts.consensus_committee_size\n | _ -> rewards\n in\n Tez_repr.mul_q ~rounding:`Down base_rewards coeff\n\n let liquidity_baking_subsidy_from_constants\n (constants : Constants_parametric_repr.t) =\n let liquidity_baking_subsidy = constants.liquidity_baking_subsidy in\n let minimal_block_delay =\n constants.minimal_block_delay |> Period_repr.to_seconds |> Int64.to_int\n in\n Tez_repr.mul_q\n ~rounding:`Down\n liquidity_baking_subsidy\n Q.(minimal_block_delay // 60)\nend\n\nopen M\n\nlet reward_from_context ~ctxt ~reward_kind =\n let csts = Raw_context.constants ctxt in\n let coeff = Raw_context.reward_coeff_for_current_cycle ctxt in\n reward_from_constants ~csts ~reward_kind ~coeff\n\nlet baking_reward_fixed_portion ctxt =\n reward_from_context ~ctxt ~reward_kind:Baking_reward_fixed_portion\n\nlet baking_reward_bonus_per_slot ctxt =\n reward_from_context ~ctxt ~reward_kind:Baking_reward_bonus_per_slot\n\nlet attesting_reward_per_slot ctxt =\n reward_from_context ~ctxt ~reward_kind:Attesting_reward_per_slot\n\nlet liquidity_baking_subsidy ctxt =\n let constants = Raw_context.constants ctxt in\n liquidity_baking_subsidy_from_constants constants\n\nlet seed_nonce_revelation_tip ctxt =\n reward_from_context ~ctxt ~reward_kind:Seed_nonce_revelation_tip\n\nlet vdf_revelation_tip ctxt =\n reward_from_context ~ctxt ~reward_kind:Vdf_revelation_tip\n\nmodule For_RPC = struct\n include M\n\n let reward_from_constants ?(coeff = Q.one)\n (csts : Constants_parametric_repr.t) ~reward_kind =\n reward_from_constants ~csts ~reward_kind ~coeff\nend\n" ;
} ;
{ name = "Delegate_missed_attestations_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_attestations} table. *)\n\nval expected_slots_for_given_active_stake :\n Raw_context.t ->\n total_active_stake_weight:int64 ->\n active_stake_weight:int64 ->\n int\n\ntype level_participation = Participated | Didn't_participate\n\n(** Record the participation of a delegate as a validator. *)\nval record_attesting_participation :\n Raw_context.t ->\n delegate:Signature.Public_key_hash.t ->\n participation:level_participation ->\n attesting_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\nmodule For_RPC : sig\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 *)\n type participation_info = {\n expected_cycle_activity : int;\n (** The total expected slots to be attested in the cycle. (static) *)\n minimal_cycle_activity : int;\n (** The minimal attesting slots in the cycle to get attesting rewards.\n (static) *)\n missed_slots : int;\n (** The number of missed attesting slots in the cycle. (dynamic) *)\n missed_levels : int;\n (** The number of missed attesting levels in the cycle. (dynamic) *)\n remaining_allowed_missed_slots : int;\n (** Remaining amount of attesting slots that can be missed in the\n cycle before forfeiting the rewards. (dynamic) *)\n expected_attesting_rewards : Tez_repr.t;\n (** Attesting 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 *)\n val participation_info :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n participation_info tzresult Lwt.t\nend\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_weight\n ~active_stake_weight =\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_attestations_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 active_stake_weight)\n (Z.of_int number_of_attestations_per_cycle))\n (Z.of_int64 total_active_stake_weight))\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_attesting_participation ctxt ~delegate ~participation\n ~attesting_power =\n let open Lwt_result_syntax in\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 let* result = Storage.Contract.Missed_attestations.find ctxt contract in\n match result with\n | Some {remaining_slots; missed_levels} ->\n let remaining_slots = remaining_slots - attesting_power in\n Storage.Contract.Missed_attestations.update\n ctxt\n contract\n {remaining_slots; missed_levels = missed_levels + 1}\n | None -> (\n let level = Level_storage.current ctxt in\n let*? stake_distribution =\n Raw_context.stake_distribution_for_current_cycle ctxt\n in\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 attestations 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 let* total_active_stake =\n Stake_storage.get_total_active_stake ctxt level.cycle\n in\n let expected_slots =\n let active_stake_weight =\n Stake_repr.staking_weight active_stake\n in\n let total_active_stake_weight =\n Stake_repr.staking_weight total_active_stake\n in\n expected_slots_for_given_active_stake\n ctxt\n ~total_active_stake_weight\n ~active_stake_weight\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 - attesting_power in\n Storage.Contract.Missed_attestations.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 let open Lwt_result_syntax in\n let* ctxt = Stake_storage.set_active ctxt payload_producer in\n let* ctxt =\n if not (Signature.Public_key_hash.equal payload_producer block_producer)\n then Stake_storage.set_active ctxt block_producer\n else return ctxt\n in\n let pay_payload_producer ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n let* ctxt, block_fees = Token.balance ctxt `Block_fees in\n let* ctxt, balance_updates_block_fees =\n Token.transfer ctxt `Block_fees (`Contract contract) block_fees\n in\n let+ ctxt, balance_updates_baking_rewards =\n Shared_stake.pay_rewards\n ctxt\n ~source:`Baking_rewards\n ~delegate\n baking_reward\n in\n (ctxt, balance_updates_block_fees @ balance_updates_baking_rewards)\n in\n let pay_block_producer ctxt delegate bonus =\n Shared_stake.pay_rewards ctxt ~source:`Baking_bonuses ~delegate bonus\n in\n let* ctxt, balance_updates_payload_producer =\n pay_payload_producer ctxt payload_producer\n in\n let* ctxt, balance_updates_block_producer =\n match reward_bonus with\n | Some bonus -> pay_block_producer ctxt block_producer bonus\n | None -> return (ctxt, [])\n in\n return\n (ctxt, balance_updates_payload_producer @ balance_updates_block_producer)\n\nlet check_and_reset_delegate_participation ctxt delegate =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Implicit delegate in\n let* missed = Storage.Contract.Missed_attestations.find ctxt contract in\n match missed with\n | None -> return (ctxt, true)\n | Some missed_attestations ->\n let*! ctxt = Storage.Contract.Missed_attestations.remove ctxt contract in\n return (ctxt, Compare.Int.(missed_attestations.remaining_slots >= 0))\n\nmodule For_RPC = struct\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_attesting_rewards : Tez_repr.t;\n }\n\n (* Inefficient, only for RPC *)\n let participation_info ctxt delegate =\n let open Lwt_result_syntax in\n let level = Level_storage.current ctxt in\n let* stake_distribution =\n Stake_storage.get_selected_distribution ctxt level.cycle\n in\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_attesting_rewards = Tez_repr.zero;\n }\n | Some active_stake ->\n let* total_active_stake =\n Stake_storage.get_total_active_stake ctxt level.cycle\n in\n let expected_cycle_activity =\n let active_stake_weight = Stake_repr.staking_weight active_stake in\n let total_active_stake_weight =\n Stake_repr.staking_weight total_active_stake\n in\n expected_slots_for_given_active_stake\n ctxt\n ~total_active_stake_weight\n ~active_stake_weight\n in\n let Ratio_repr.{numerator; denominator} =\n Constants_storage.minimal_participation_ratio ctxt\n in\n let*? attesting_reward_per_slot =\n Delegate_rewards.attesting_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_attesting_rewards =\n Tez_repr.mul_exn attesting_reward_per_slot expected_cycle_activity\n in\n let contract = Contract_repr.Implicit delegate in\n let* missed_attestations =\n Storage.Contract.Missed_attestations.find ctxt contract\n in\n let missed_slots, missed_levels, remaining_allowed_missed_slots =\n match missed_attestations 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_attesting_rewards =\n match missed_attestations with\n | Some r when Compare.Int.(r.remaining_slots < 0) -> Tez_repr.zero\n | _ -> expected_attesting_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_attesting_rewards;\n }\nend\n" ;
} ;
{ name = "Already_denounced_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\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(*****************************************************************************)\n\n(** This module is responsible for ensuring that a delegate doesn't\n get slashed twice for the same offense. To do so, it maintains the\n {!Storage.Already_denounced} table, which tracks which\n denunciations have already been seen in blocks.\n\n A denunciation is uniquely characterized by the delegate (the\n culprit), the level and round of the duplicate block or\n (pre)attestation, and the {!type-Misbehaviour_repr.kind} (double\n baking/attesting/preattesting).\n\n Invariant: {!Storage.Already_denounced} is empty for cycles equal\n to [current_cycle - max_slashing_period] or older. Indeed, such\n denunciations are no longer allowed (see\n [Anonymous.check_denunciation_age] in {!Validate}) so there is no\n need to track them anymore. *)\n\n(** Returns true if the given delegate has already been denounced\n for the given misbehaviour kind at the given level and round. *)\nval already_denounced :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Level_repr.t ->\n Round_repr.t ->\n Misbehaviour_repr.kind ->\n bool tzresult Lwt.t\n\n(** Records a denunciation in {!Storage.Already_denounced}.\n\n Returns a pair [(ctxt, already_denounced)], where\n [already_denounced] is a boolean indicating whether the\n denunciation was already recorded in the storage previously.\n\n When [already_denounced] is [true], the returned [ctxt] is\n actually the unchanged context argument.\n\n Precondition: the given level should be more recent than\n [current_cycle - max_slashing_period] in order to maintain the\n invariant on the age of tracked denunciations. Fortunately, this\n is already enforced in {!Validate} by\n [Anonymous.check_denunciation_age]. *)\nval add_denunciation :\n Raw_context.t ->\n Signature.public_key_hash ->\n Level_repr.t ->\n Round_repr.t ->\n Misbehaviour_repr.kind ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** Clear {!Storage.Already_denounced} for the cycle [new_cycle -\n max_slashing_period]. Indeed, denunciations on events which\n happened during this cycle are no longer allowed anyway. *)\nval clear_outdated_cycle :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\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(*****************************************************************************)\n\nlet already_denounced_aux ctxt delegate (level : Level_repr.t) round kind =\n let open Lwt_result_syntax in\n let* denounced_opt =\n Storage.Already_denounced.find\n (ctxt, level.cycle)\n ((level.level, round), delegate)\n in\n match (denounced_opt, (kind : Misbehaviour_repr.kind)) with\n | None, _ -> return_false\n | Some denounced, Double_preattesting ->\n return denounced.for_double_preattesting\n | Some denounced, Double_attesting -> return denounced.for_double_attesting\n | Some denounced, Double_baking -> return denounced.for_double_baking\n\nlet already_denounced ctxt delegate level round kind =\n let open Lwt_result_syntax in\n let* answer = already_denounced_aux ctxt delegate level round kind in\n if answer || Round_repr.(round = zero) then return answer\n else\n let* first_level = Storage.Tenderbake.First_level_of_protocol.get ctxt in\n if Raw_level_repr.(level.level >= first_level) then return answer\n else\n (* Exception related to the migration from Oxford to P: because\n Oxford doesn't record the round of misbehaviours, all\n misbehaviours present in the storage at stitching time got\n assigned the round zero. So we also check with the round set\n to zero in the specific case where a misbehaviour:\n\n - is old enough to have potentially been denounced during\n Oxford (ie. its level is before the first level of P),\n\n - has a non-zero round (otherwise the new check is identical\n to the previous one anyway), and\n\n - has not been found in the storage under its own round\n (ie. [answer] is [false]).\n\n TODO #6957: This whole control flow should be removed from\n protocol Q. *)\n already_denounced_aux ctxt delegate level Round_repr.zero kind\n\nlet add_denunciation ctxt delegate (level : Level_repr.t) round kind =\n let open Lwt_result_syntax in\n let* denounced_opt =\n Storage.Already_denounced.find\n (ctxt, level.cycle)\n ((level.level, round), delegate)\n in\n let denounced =\n Option.value denounced_opt ~default:Storage.default_denounced\n in\n let already_denounced =\n match kind with\n | Misbehaviour_repr.Double_baking -> denounced.for_double_baking\n | Double_attesting -> denounced.for_double_attesting\n | Double_preattesting -> denounced.for_double_preattesting\n in\n let*! ctxt =\n if already_denounced then Lwt.return ctxt\n else\n Storage.Already_denounced.add\n (ctxt, level.cycle)\n ((level.level, round), delegate)\n (match kind with\n | Double_baking -> {denounced with for_double_baking = true}\n | Double_attesting -> {denounced with for_double_attesting = true}\n | Double_preattesting -> {denounced with for_double_preattesting = true})\n in\n return (ctxt, already_denounced)\n\nlet clear_outdated_cycle ctxt ~new_cycle =\n match Cycle_repr.(sub new_cycle Constants_repr.max_slashing_period) with\n | None -> Lwt.return ctxt\n | Some outdated_cycle -> Storage.Already_denounced.clear (ctxt, outdated_cycle)\n" ;
} ;
{ name = "Forbidden_delegates_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** This module maintains the storage related to forbidden delegates.\n It is responsible for maintaining the\n {!Storage.Tenderbake.Forbidden_delegates} table.\n*)\n\n(** [is_forbidden ctxt delegate] returns [true] if the given [delegate]\n is forbidden to bake or attest. *)\nval is_forbidden : Raw_context.t -> Signature.Public_key_hash.t -> bool\n\n(** [forbid ctxt delegate] adds [delegate] to the set of forbidden\n delegates. *)\nval forbid : Raw_context.t -> Signature.public_key_hash -> Raw_context.t Lwt.t\n\n(** [load ctxt] reads from the storage the saved set of\n forbidden delegates and sets the raw context's in-memory cached value. *)\nval load : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** Unforbids all delegates who\n\n - have no pending denunciations (for which slashing has yet to be\n applied), and\n\n - have enough current frozen deposits to insure their previously\n computed baking rights for [new_cycle].\n\n This function should be called at the end of each cycle, after\n having applied any slashings that were scheduled for the same\n cycle end. *)\nval update_at_cycle_end_after_slashing :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n\nval init_for_genesis : Raw_context.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2023 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\nlet is_forbidden ctxt delegate =\n let forbidden_delegates = Raw_context.Consensus.forbidden_delegates ctxt in\n Signature.Public_key_hash.Set.mem delegate forbidden_delegates\n\nlet forbid ctxt delegate =\n let ctxt = Raw_context.Consensus.forbid_delegate ctxt delegate in\n let new_forbidden_delegates =\n Raw_context.Consensus.forbidden_delegates ctxt\n in\n Storage.Tenderbake.Forbidden_delegates.add ctxt new_forbidden_delegates\n\nlet load ctxt =\n let open Lwt_result_syntax in\n let* forbidden_delegates_opt =\n Storage.Tenderbake.Forbidden_delegates.find ctxt\n in\n let ctxt =\n match forbidden_delegates_opt with\n | Some forbidden_delegates ->\n Raw_context.Consensus.set_forbidden_delegates ctxt forbidden_delegates\n | None ->\n Raw_context.Consensus.set_forbidden_delegates\n ctxt\n Signature.Public_key_hash.Set.empty\n in\n return ctxt\n\nlet set_forbidden_delegates ctxt forbidden_delegates =\n let open Lwt_syntax in\n let* ctxt =\n Storage.Tenderbake.Forbidden_delegates.add ctxt forbidden_delegates\n in\n let ctxt =\n Raw_context.Consensus.set_forbidden_delegates ctxt forbidden_delegates\n in\n return ctxt\n\nlet should_unforbid ctxt delegate ~selection_for_new_cycle =\n let open Lwt_result_syntax in\n (* A delegate who has pending denunciations for which slashing has\n not been applied yet should stay forbidden, because their frozen\n deposits are going to decrease by a yet unknown amount. *)\n let*! has_pending_denunciations =\n Pending_denunciations_storage.has_pending_denunciations ctxt delegate\n in\n if has_pending_denunciations then return_false\n else\n (* To get unforbidden, a delegate's current frozen deposits must\n be high enough to insure the next cycle's baking rights. More\n precisely, their [current_frozen_deposits] must at least match\n [frozen], where:\n\n - [current_frozen_deposits] is the sum of the delegate's own\n frozen funds and their stakers'; it doesn't necessarily observe\n overstaking limits.\n\n - [frozen] is the frozen stake that was used in the past to\n compute the baking rights for the new cycle. It includes past\n frozen balances from the delegate and their stakers, but\n excludes any overstaked funds (as enforced by\n {!Stake_context.apply_limits}). *)\n match\n Signature.Public_key_hash.Map.find delegate selection_for_new_cycle\n with\n | None -> return_true\n | Some {Stake_repr.frozen; _} ->\n let* current_frozen_deposits =\n Delegate_storage.current_frozen_deposits ctxt delegate\n in\n return Tez_repr.(current_frozen_deposits >= frozen)\n\nlet update_at_cycle_end_after_slashing ctxt ~new_cycle =\n let open Lwt_result_syntax in\n let forbidden_delegates = Raw_context.Consensus.forbidden_delegates ctxt in\n if Signature.Public_key_hash.Set.is_empty forbidden_delegates then return ctxt\n else\n let* selection_for_new_cycle =\n Stake_storage.get_selected_distribution_as_map ctxt new_cycle\n in\n let* forbidden_delegates =\n Signature.Public_key_hash.Set.fold_es\n (fun delegate acc ->\n let* should_unforbid =\n should_unforbid ctxt delegate ~selection_for_new_cycle\n in\n if should_unforbid then\n let old_forbidden =\n match acc with\n | `Unchanged -> forbidden_delegates\n | `Changed forbidden_delegates -> forbidden_delegates\n in\n let new_forbidden =\n Signature.Public_key_hash.Set.remove delegate old_forbidden\n in\n return (`Changed new_forbidden)\n else return acc)\n forbidden_delegates\n `Unchanged\n in\n match forbidden_delegates with\n | `Unchanged -> return ctxt\n | `Changed forbidden_delegates ->\n let*! ctxt = set_forbidden_delegates ctxt forbidden_delegates in\n return ctxt\n\nlet init_for_genesis ctxt =\n Storage.Tenderbake.Forbidden_delegates.init\n ctxt\n Signature.Public_key_hash.Set.empty\n" ;
} ;
{ name = "Slash_percentage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2024 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\n(** [get ctxt ~kind ~level denounced] returns the percentage that needs to be\n applied for the given misbehaviour.\n\n [denounced] is the list of delegates that have been denounced together for\n the given [kind], for the given [level] and for the same round. The amount\n slashed increases quadratically as the number of attesting slots of\n denounced delegates increases. The maximum slashing value\n [max_slashing_per_block] is reached when that number of slots reaches\n [max_slashing_threshold] . *)\nval get :\n Raw_context.t ->\n kind:Misbehaviour_repr.kind ->\n level:Level_repr.t ->\n Signature.public_key_hash list ->\n (Raw_context.t * Percentage.t) tzresult Lwt.t\n\nmodule Internal_for_tests : sig\n val for_double_attestation :\n Raw_context.t ->\n int Signature.Public_key_hash.Map.t ->\n Signature.Public_key_hash.t list ->\n Percentage.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2024 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\nlet for_double_baking ctxt =\n Constants_storage.percentage_of_frozen_deposits_slashed_per_double_baking ctxt\n\nlet for_double_attestation ctxt rights denounced =\n if\n not\n (Constants_storage.adaptive_issuance_ns_enable ctxt\n && Constants_storage.adaptive_issuance_enable ctxt)\n then\n Constants_storage\n .percentage_of_frozen_deposits_slashed_per_double_attestation\n ctxt\n else\n let total_rights_denounced =\n List.fold_left\n (fun total delegate ->\n Option.value\n (Signature.Public_key_hash.Map.find delegate rights)\n ~default:0\n |> ( + ) total)\n 0\n denounced\n in\n let threshold_max = (Raw_context.constants ctxt).max_slashing_threshold in\n let max_slashing = (Raw_context.constants ctxt).max_slashing_per_block in\n if Compare.Int.(total_rights_denounced >= threshold_max) then max_slashing\n else\n let num_z = Z.(pow (of_int total_rights_denounced) 2) in\n let den_z = Z.(pow (of_int threshold_max) 2) in\n Percentage.mul_q_bounded ~round:`Up max_slashing Q.(num_z /// den_z)\n\nlet get ctxt ~(kind : Misbehaviour_repr.kind) ~(level : Level_repr.t)\n (denounced : Signature.public_key_hash list) =\n let open Lwt_result_syntax in\n match kind with\n | Double_baking -> return (ctxt, for_double_baking ctxt)\n | Double_attesting | Double_preattesting ->\n let* ctxt, rights = Delegate_sampler.attesting_rights_count ctxt level in\n return (ctxt, for_double_attestation ctxt rights denounced)\n\nmodule Internal_for_tests = struct\n let for_double_attestation = for_double_attestation\nend\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 handles the slashing of delegates for double signing.\n\n It is behind the {!Alpha_context} abstraction: some functions are\n re-exported in {!Alpha_context.Delegate}.\n\n This module is responsible for maintaining the\n {!Storage.Contract.Slashed_deposits} table. It also interacts\n heavily with {!Pending_denunciations_storage}.\n*)\n\n(** The [reward_and_burn] type embeds amounts involved when slashing a\n delegate for double attesting or double baking. *)\ntype reward_and_burn = {reward : Tez_repr.t; amount_to_burn : Tez_repr.t}\n\n(** The [punishing_amounts] type embeds amounts involved when slashing a\n delegate for double attesting or double baking. *)\ntype punishing_amounts = {\n staked : reward_and_burn;\n unstaked : (Cycle_repr.t * reward_and_burn) list;\n}\n\n(** Record in the context that the given delegate is both marked for\n slashing for the given misbehaviour, and forbidden from taking\n part in the consensus process (baking/attesting).\n\n [operation_hash] corresponds to the denunciation that prompted\n this punishment. The level argument is the level of the duplicate\n blocks, or the level that the duplicate (pre)attestations point\n to, **not** the level of the block that contains the denunciation.\n\n This function asserts that the delegate has not already been\n denounced for the same misbehaviour at the same level. Indeed, if\n this were the case, then the current denunciation operation should\n have been rejected by {!Validate}. *)\nval punish_double_signing :\n Raw_context.t ->\n operation_hash:Operation_hash.t ->\n Misbehaviour_repr.t ->\n Signature.Public_key_hash.t ->\n Level_repr.t ->\n rewarded:Signature.public_key_hash ->\n Raw_context.t tzresult Lwt.t\n\n(** Applies pending denunciations in {!Storage.Pending_denunciations}\n at the end of a cycle. The applicable denunciations are those that\n point to a misbehavior whose max slashable period is ending.\n (because [max_slashable_period = 2], the misbehavior must be\n in the previous cycle).\n\n The denunciations are applied in chronological order of misbehaviour.\n This function slashes the misbehaving bakers, by a proportion defined\n in {!Slash_percentage}, and updates the respective\n {!Storage.Contract.Slashed_deposits}. The applied denunciations are\n removed from the storage.\n\n It returns the updated context, and all the balance updates,\n which includes slashes for the bakers, the stakers, and the rewards\n for the denouncers.\n*)\nval apply_and_clear_denunciations :\n Raw_context.t -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\nmodule For_RPC : sig\n (** [get_estimated_shared_pending_slashed_amount ctxt delegate]\n returns the estimated shared pending slashed amount of the given [delegate]\n according to the currently available denunciations. *)\n val get_estimated_shared_pending_slashed_amount :\n Raw_context.t -> Signature.public_key_hash -> Tez_repr.t tzresult Lwt.t\n\n (** [get_estimated_own_pending_slashed_amount ctxt contract]\n returns the estimated own pending slashed amount of the given [contract]\n according to the currently available denunciations. *)\n val get_estimated_own_pending_slashed_amount :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t\nend\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 reward_and_burn = {reward : Tez_repr.t; amount_to_burn : Tez_repr.t}\n\ntype punishing_amounts = {\n staked : reward_and_burn;\n unstaked : (Cycle_repr.t * reward_and_burn) list;\n}\n\nlet record_denunciation ctxt ~operation_hash\n (misbehaviour : Misbehaviour_repr.t) delegate ~rewarded =\n let open Lwt_result_syntax in\n let*! ctxt = Forbidden_delegates_storage.forbid ctxt delegate in\n Pending_denunciations_storage.add_denunciation\n ctxt\n ~misbehaving_delegate:delegate\n operation_hash\n ~rewarded_delegate:rewarded\n misbehaviour\n\nlet punish_double_signing ctxt ~operation_hash misbehaviour delegate\n (level : Level_repr.t) ~rewarded =\n let open Lwt_result_syntax in\n let* ctxt, was_already_denounced =\n Already_denounced_storage.add_denunciation\n ctxt\n delegate\n level\n misbehaviour.Misbehaviour_repr.round\n misbehaviour.kind\n in\n if was_already_denounced then\n (* This can only happen in the very specific case where a delegate\n has crafted at least three attestations (respectively\n preattestations) on the same level and round but with three\n different slots owned by this delegate. Indeed, this makes it\n possible to have two denunciations about the same delegate,\n level, round, and kind, but different slots. Such denunciations\n are considered identical by {!Already_denounced_storage}, which\n is good because the delegate shouldn't get slashed twice on the\n same level, round, and kind. However, {!Validate}'s conflict\n handler identifies denunciations via their slot rather than\n delegate for technical reasons (because the slot is readily\n available whereas retrieving the delegate requires a call to\n {!Delegate_sampler.slot_owner} which is in Lwt and thus\n incompatible with some signatures). Therefore, if these\n denunciations (which differ only in their slots) are both\n included in the same block, then they will both be successfully\n validated, and then [was_already_denounced] will be [true]\n during the application of the second one.\n\n In this unlikely scenario, we simply ignore the redundant\n denunciation silently. Returning an error or raising an\n exception here would cause the whole block application to fail,\n which we don't want. *)\n return ctxt\n else record_denunciation ctxt ~operation_hash misbehaviour delegate ~rewarded\n\n(* Misbehaviour Map: orders denunciations for application.\n See {!Misbehaviour_repr.compare} for the order on misbehaviours:\n - by increasing level, then increasing round, then kind, ignoring the slot\n - for the kind: double baking > double attesting > double preattesting *)\nmodule MisMap = Map.Make (Misbehaviour_repr)\n\nlet compute_punishing_amount slashing_percentage frozen_deposits =\n let punish_value =\n Tez_repr.mul_percentage\n ~rounding:`Down\n frozen_deposits.Deposits_repr.initial_amount\n slashing_percentage\n in\n Tez_repr.min punish_value frozen_deposits.Deposits_repr.current_amount\n\nlet split_reward_and_burn punishing_amount global_limit_of_staking_over_baking =\n let open Result_syntax in\n let global_limit_of_staking_over_baking_plus_two =\n Int64.add (Int64.of_int global_limit_of_staking_over_baking) 2L\n in\n let* reward =\n Tez_repr.(punishing_amount /? global_limit_of_staking_over_baking_plus_two)\n in\n let+ amount_to_burn = Tez_repr.(punishing_amount -? reward) in\n {reward; amount_to_burn}\n\nlet compute_reward_and_burn slashing_percentage frozen_deposits\n global_limit_of_staking_over_baking =\n let punishing_amount =\n compute_punishing_amount slashing_percentage frozen_deposits\n in\n split_reward_and_burn punishing_amount global_limit_of_staking_over_baking\n\nlet get_initial_frozen_deposits_of_misbehaviour_cycle ~current_cycle\n ~misbehaviour_cycle =\n let previous_cycle =\n match Cycle_repr.pred current_cycle with\n | None -> current_cycle\n | Some previous_cycle -> previous_cycle\n in\n if Cycle_repr.equal current_cycle misbehaviour_cycle then\n Delegate_storage.initial_frozen_deposits\n else if Cycle_repr.equal previous_cycle misbehaviour_cycle then\n Delegate_storage.initial_frozen_deposits_of_previous_cycle\n else fun (_ : Raw_context.t) (_ : Signature.public_key_hash) ->\n (* Denunciation applied too late.\n We could assert false, but we can also be permissive\n while keeping the same invariants. *)\n return Tez_repr.zero\n\nlet update_block_denunciations_map_with delegate denunciations initial_block_map\n =\n List.fold_left\n (fun block_map denunciation ->\n MisMap.update\n denunciation.Denunciations_repr.misbehaviour\n (function\n | None ->\n Some\n (Signature.Public_key_hash.Map.singleton delegate denunciation)\n | Some map ->\n Some\n (Signature.Public_key_hash.Map.update\n delegate\n (function\n | None -> Some denunciation | Some old_d -> Some old_d)\n map))\n block_map)\n initial_block_map\n denunciations\n\n(* Split denunciations into two groups: those to be applied, and those to be delayed. *)\nlet get_applicable_and_remaining_denunciations ctxt current_cycle =\n Storage.Pending_denunciations.fold\n ctxt\n ~order:`Undefined\n ~init:(MisMap.empty, [])\n ~f:(fun delegate denunciations acc ->\n let block_map, remaining_denunciations = acc in\n (* Since the [max_slashing_period] is 2, and we want to apply denunciations at the\n end of this period, we \"delay\" the current cycle's misbehaviour's denunciations,\n while we apply the older denunciations.\n Indeed, we apply denunciations in the cycle following the misbehaviour, so that\n the time between the misbehaviour and the slashing is at most\n [max_slashing_period = 2] cycles. *)\n let denunciations_to_apply, denunciations_to_delay =\n if not (Constants_storage.adaptive_issuance_ns_enable ctxt) then\n (denunciations, [])\n else\n List.partition\n (fun denunciation ->\n let level = denunciation.Denunciations_repr.misbehaviour.level in\n let misb_cycle =\n (Level_repr.level_from_raw\n ~cycle_eras:(Raw_context.cycle_eras ctxt)\n level)\n .cycle\n in\n Cycle_repr.(misb_cycle < current_cycle))\n denunciations\n in\n let new_block_map =\n update_block_denunciations_map_with\n delegate\n denunciations_to_apply\n block_map\n in\n let new_remaining_denunciations =\n (delegate, denunciations_to_delay) :: remaining_denunciations\n in\n Lwt.return (new_block_map, new_remaining_denunciations))\n\nlet apply_block_denunciations ctxt current_cycle block_denunciations_map =\n let slashable_deposits_period =\n Constants_storage.slashable_deposits_period ctxt\n in\n let open Lwt_result_syntax in\n let global_limit_of_staking_over_baking =\n Constants_storage.adaptive_issuance_global_limit_of_staking_over_baking ctxt\n in\n MisMap.fold_es\n (fun ({Misbehaviour_repr.level = raw_level; round = _; kind; _} as miskey)\n denunciations_map\n acc ->\n let ctxt, balance_updates = acc in\n let level =\n Level_repr.level_from_raw\n ~cycle_eras:(Raw_context.cycle_eras ctxt)\n raw_level\n in\n let misbehaviour_cycle = level.cycle in\n let denunciations =\n Signature.Public_key_hash.Map.bindings denunciations_map\n in\n let denounced = List.map fst denunciations in\n let* ctxt, slashing_percentage =\n Slash_percentage.get ctxt ~kind ~level denounced\n in\n let+ ctxt, balance_updates =\n List.fold_left_es\n (fun (ctxt, balance_updates)\n ( delegate,\n Denunciations_repr.{operation_hash; rewarded; misbehaviour} ) ->\n assert (\n Compare.Int.equal\n (* This compare ignores the slot *)\n (Misbehaviour_repr.compare miskey misbehaviour)\n 0) ;\n (* Validate ensures that [denunciations] contains [delegate] at most once *)\n let delegate_contract = Contract_repr.Implicit delegate in\n (* Oxford values *)\n let* slash_history_opt_o =\n Storage.Contract.Slashed_deposits__Oxford.find\n ctxt\n delegate_contract\n in\n let slash_history_o =\n Option.value slash_history_opt_o ~default:[]\n |> List.map (fun (a, b) -> (a, Percentage.convert_from_o_to_p b))\n in\n\n let* slash_history_opt =\n Storage.Slashed_deposits.find ctxt delegate\n in\n let slash_history = Option.value slash_history_opt ~default:[] in\n\n (* Concatenate both, Oxford first *)\n let slash_history =\n List.fold_left\n (fun acc (cycle, percentage) ->\n Storage.Slashed_deposits_history.add cycle percentage acc)\n slash_history_o\n slash_history\n in\n\n let*! ctxt =\n Storage.Contract.Slashed_deposits__Oxford.remove\n ctxt\n delegate_contract\n in\n\n let previous_total_slashing_percentage =\n Storage.Slashed_deposits_history.get level.cycle slash_history\n in\n let slash_history =\n Storage.Slashed_deposits_history.add\n level.cycle\n slashing_percentage\n slash_history\n in\n let*! ctxt =\n Storage.Slashed_deposits.add ctxt delegate slash_history\n in\n let new_total_slashing_percentage =\n Storage.Slashed_deposits_history.get level.cycle slash_history\n in\n (* We do not slash above 100%: if the slashing percentage would\n make the total sum of the slashing history above 100%, we rectify\n it to reach exactly 100%. This also means that subsequent slashes\n are effectively ignored (set to 0%) *)\n let slashing_percentage =\n Percentage.sub_bounded\n new_total_slashing_percentage\n previous_total_slashing_percentage\n in\n let* frozen_deposits =\n let* initial_amount =\n get_initial_frozen_deposits_of_misbehaviour_cycle\n ~current_cycle\n ~misbehaviour_cycle\n ctxt\n delegate\n in\n let* current_amount =\n Delegate_storage.current_frozen_deposits ctxt delegate\n in\n return Deposits_repr.{initial_amount; current_amount}\n in\n let punishing_amount =\n compute_punishing_amount slashing_percentage frozen_deposits\n (* Ensures: [punishing_amount <= current_amount]\n\n where [current_amount = frozen_deposits.current_amount\n = own_frozen + staked_frozen]\n *)\n in\n let* {baker_part; stakers_part = _} =\n Shared_stake.share\n ~rounding:`Towards_baker\n ctxt\n delegate\n punishing_amount\n (* Ensures:\n\n - [baker_part + stakers_part = punishing_amount]\n\n - [baker_part / punishing_amount = own_frozen / (own_frozen + allowed_staked_frozen)]\n\n where [allowed_staked_frozen] is [staked_frozen]\n capped by the delegate's [limit_of_staking_over_baking],\n which notably means that [allowed_staked_frozen <= staked_frozen]\n i.e. [own_frozen + allowed_staked_frozen <= own_frozen + staked_frozen = current_amount]\n\n Combining all of the above:\n\n [baker_part / punishing_amount >= own_frozen / current_amount]\n\n [(punishing_amount - stakers_part) / punishing_amount >= (current_amount - staked_frozen) / current_amount]\n\n [1 - (stakers_part / punishing_amount) >= 1 - (staked_frozen / current_amount)]\n\n [stakers_part / punishing_amount <= staked_frozen / current_amount]\n\n [stakers_part <= staked_frozen * punishing_amount / current_amount]\n\n Moreover, we know from above that [punishing_amount <= current_amount] so:\n\n [stakers_part <= staked_frozen]\n *)\n in\n let* full_staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n let own_frozen =\n Full_staking_balance_repr.own_frozen full_staking_balance\n in\n let actual_baker_part = Tez_repr.min baker_part own_frozen in\n let*? actual_stakers_part =\n Tez_repr.(punishing_amount -? actual_baker_part)\n in\n (* To avoid underflows, we need to guarantee that:\n - [actual_baker_part <= own_frozen] and\n - [actual_stakers_part <= staked_frozen]\n\n The [min] ensures that [actual_baker_part <= own_frozen].\n\n For [actual_stakers_part], let's examine two cases\n based on the [min]:\n\n - Case 1: [actual_baker_part = baker_part]\n\n [actual_stakers_part = punishing_amount - actual_baker_part\n = punishing_amount - baker_part\n = stakers_part\n <= staked_frozen] as proven above\n\n - Case 2: [actual_baker_part = own_frozen]\n\n [actual_stakers_part = punishing_amount - actual_baker_part\n = punishing_amount - own_frozen\n <= current_amount - own_frozen\n = own_frozen + staked_frozen - own_frozen\n = staked_frozen]\n *)\n let*? {amount_to_burn = to_burn_baker; reward = to_reward_baker} =\n split_reward_and_burn\n actual_baker_part\n global_limit_of_staking_over_baking\n in\n let*? {amount_to_burn = to_burn_stakers; reward = to_reward_stakers}\n =\n split_reward_and_burn\n actual_stakers_part\n global_limit_of_staking_over_baking\n in\n let giver_baker =\n `Frozen_deposits (Frozen_staker_repr.baker delegate)\n in\n let giver_stakers =\n `Frozen_deposits\n (Frozen_staker_repr.shared_between_stakers ~delegate)\n in\n let init_to_burn =\n [(giver_baker, to_burn_baker); (giver_stakers, to_burn_stakers)]\n in\n let init_to_reward =\n [\n (giver_baker, to_reward_baker);\n (giver_stakers, to_reward_stakers);\n ]\n in\n let* to_burn, to_reward =\n let oldest_slashable_cycle =\n Cycle_repr.sub misbehaviour_cycle slashable_deposits_period\n |> Option.value ~default:Cycle_repr.root\n in\n let slashable_cycles =\n Cycle_repr.(oldest_slashable_cycle ---> misbehaviour_cycle)\n in\n List.fold_left_es\n (fun (to_burn, to_reward) cycle ->\n let* frozen_deposits =\n Unstaked_frozen_deposits_storage.get ctxt delegate cycle\n in\n let*? {amount_to_burn; reward} =\n compute_reward_and_burn\n slashing_percentage\n frozen_deposits\n global_limit_of_staking_over_baking\n in\n let giver =\n `Unstaked_frozen_deposits\n (Unstaked_frozen_staker_repr.Shared delegate, cycle)\n in\n return\n ( (giver, amount_to_burn) :: to_burn,\n (giver, reward) :: to_reward ))\n (init_to_burn, init_to_reward)\n slashable_cycles\n in\n let origin = Receipt_repr.Delayed_operation {operation_hash} in\n let* ctxt, punish_balance_updates =\n Token.transfer_n ctxt ~origin to_burn `Double_signing_punishments\n in\n let+ ctxt, reward_balance_updates =\n Token.transfer_n\n ctxt\n ~origin\n to_reward\n (`Contract (Contract_repr.Implicit rewarded))\n in\n ( ctxt,\n punish_balance_updates @ reward_balance_updates @ balance_updates\n ))\n (ctxt, balance_updates)\n denunciations\n in\n (ctxt, balance_updates))\n block_denunciations_map\n (ctxt, [])\n\nlet apply_denunciations ctxt =\n let open Lwt_result_syntax in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let*! applicable_denunciations_map, remaining_denunciations =\n get_applicable_and_remaining_denunciations ctxt current_cycle\n in\n let* ctxt, balance_updates =\n apply_block_denunciations ctxt current_cycle applicable_denunciations_map\n in\n return (ctxt, balance_updates, remaining_denunciations)\n\nlet apply_and_clear_denunciations ctxt =\n let open Lwt_result_syntax in\n let* ctxt, balance_updates, remaining_denunciations =\n apply_denunciations ctxt\n in\n (* Updates the storage to only contain the remaining denunciations *)\n let*! ctxt = Pending_denunciations_storage.clear ctxt in\n let*! ctxt =\n List.fold_left_s\n (fun ctxt (delegate, current_cycle_denunciations) ->\n match current_cycle_denunciations with\n | [] -> Lwt.return ctxt\n | _ ->\n Pending_denunciations_storage.set_denunciations\n ctxt\n delegate\n current_cycle_denunciations)\n ctxt\n remaining_denunciations\n in\n return (ctxt, balance_updates)\n\nmodule For_RPC = struct\n let get_pending_misbehaviour_map ctxt =\n Storage.Pending_denunciations.fold\n ctxt\n ~order:`Undefined\n ~init:MisMap.empty\n ~f:(fun delegate denunciations block_map ->\n let new_block_map =\n update_block_denunciations_map_with delegate denunciations block_map\n in\n Lwt.return new_block_map)\n\n let get_estimated_punished_amount ctxt delegate =\n let open Lwt_result_syntax in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let* denunciations = Storage.Pending_denunciations.find ctxt delegate in\n match denunciations with\n | None | Some [] -> return Tez_repr.zero\n | Some denunciations ->\n let*! pending_misbehaviour_map = get_pending_misbehaviour_map ctxt in\n List.fold_left_es\n (fun estimated_punishing_amount denunciation ->\n let ({Misbehaviour_repr.level = raw_level; kind; _} as\n misbehaviour_key) =\n denunciation.Denunciations_repr.misbehaviour\n in\n match MisMap.find misbehaviour_key pending_misbehaviour_map with\n | None ->\n (* Should not happen as [pending_misbehaviour_map] has been created\n using the bindings of [Storage.Pending_denunciations] and\n [denunciation] belongs to [Storage.Pending_denunciations]. *)\n return estimated_punishing_amount\n | Some denunciations ->\n let level =\n Level_repr.level_from_raw\n ~cycle_eras:(Raw_context.cycle_eras ctxt)\n raw_level\n in\n let denounced_pkhs =\n List.map\n fst\n (Signature.Public_key_hash.Map.bindings denunciations)\n in\n let* ctxt, slashing_percentage =\n Slash_percentage.get ctxt ~kind ~level denounced_pkhs\n in\n let misbehaviour_cycle = level.cycle in\n let* frozen_deposits =\n let* initial_amount =\n get_initial_frozen_deposits_of_misbehaviour_cycle\n ~current_cycle\n ~misbehaviour_cycle\n ctxt\n delegate\n in\n let* current_amount =\n Delegate_storage.current_frozen_deposits ctxt delegate\n in\n return {Deposits_repr.initial_amount; current_amount}\n in\n let punishing_amount =\n compute_punishing_amount slashing_percentage frozen_deposits\n in\n let new_estimated_punishing_amount =\n Tez_repr.(punishing_amount +? estimated_punishing_amount)\n in\n Lwt.return new_estimated_punishing_amount)\n Tez_repr.zero\n denunciations\n\n let get_estimated_punished_share ctxt delegate =\n let open Lwt_result_syntax in\n let* estimated_punished_amount =\n get_estimated_punished_amount ctxt delegate\n in\n Shared_stake.share\n ~rounding:`Towards_baker\n ctxt\n delegate\n estimated_punished_amount\n\n let get_estimated_shared_pending_slashed_amount ctxt delegate =\n let open Lwt_result_syntax in\n let* {baker_part; stakers_part} =\n get_estimated_punished_share ctxt delegate\n in\n Lwt.return Tez_repr.(baker_part +? stakers_part)\n\n let get_delegate_estimated_own_pending_slashed_amount ctxt ~delegate =\n let open Lwt_result_syntax in\n let+ {baker_part; stakers_part = _} =\n get_estimated_punished_share ctxt delegate\n in\n baker_part\n\n let get_estimated_own_pending_slashed_amount ctxt contract =\n let open Lwt_result_syntax in\n let* delegate_opt = Contract_delegate_storage.find ctxt contract in\n match delegate_opt with\n | None -> return Tez_repr.zero\n | Some delegate ->\n if Contract_repr.(equal (Contract_repr.Implicit delegate) contract) then\n get_delegate_estimated_own_pending_slashed_amount ctxt ~delegate\n else\n let* {baker_part = _; stakers_part} =\n get_estimated_punished_share ctxt delegate\n in\n let* num =\n let+ staking_pseudotokens =\n Staking_pseudotokens_storage.For_RPC.staking_pseudotokens_balance\n ctxt\n ~delegator:contract\n in\n Staking_pseudotoken_repr.to_int64 staking_pseudotokens\n in\n let* den =\n let+ frozen_deposits_pseudotokens =\n Staking_pseudotokens_storage.For_RPC\n .get_frozen_deposits_pseudotokens\n ctxt\n ~delegate\n in\n Staking_pseudotoken_repr.to_int64 frozen_deposits_pseudotokens\n in\n Lwt.return (Tez_repr.mul_ratio ~rounding:`Up stakers_part ~num ~den)\nend\n" ;
} ;
{ name = "Staking" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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(** [stake ctxt ~sender ~for_next_cycle_use_only_after_slashing ~delegate amount]\n add [amount] as [sender]'s stake to [delegate].\n\n If [for_next_cycle_use_only_after_slashing] is true, the implicit\n finalisation is done for the next cycle. It is meant to be used only at\n cycle end after the application of the slashing.\n\n *)\nval stake :\n Raw_context.t ->\n for_next_cycle_use_only_after_slashing:bool ->\n amount:[`At_most of Tez_repr.t | `Exactly of Tez_repr.t] ->\n sender:Signature.Public_key_hash.t ->\n delegate:Signature.public_key_hash ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [request_unstake ctxt ~for_next_cycle_use_only_after_slashing ~sender_contract ~delegate amount]\n records a request from [sender_contract] to unstake [amount] from [delegate].\n\n If [for_next_cycle_use_only_after_slashing] is true, the unstake request and\n the implicit finalisation is done for the next cycle. It is meant to be used\n only at cycle end after the application of the slashing. *)\nval request_unstake :\n Raw_context.t ->\n for_next_cycle_use_only_after_slashing:bool ->\n sender_contract:Contract_repr.t ->\n delegate:Signature.public_key_hash ->\n Tez_repr.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [finalize_unstake ctxt ~for_next_cycle_use_only_after_slashing contract]\n performs the finalization of all unstake requests from [contract] that can\n be finalized.\n An unstake request can be finalized if it is old enough, specifically the\n requested amount must not be at stake anymore and must not be slashable\n anymore, i.e. after [consensus_rights_delay + max_slashing_period] after the\n request.\n Amounts are transferred from the [contract]'s delegate (at request time)\n unstaked frozen deposits to [contract]'s spendable balance, minus slashing\n the requested stake undergone in between.\n\n If [for_next_cycle_use_only_after_slashing] is true, the finalization is\n done for the next cycle. It is meant to be used only at cycle end after the\n application of the slashing.*)\nval finalize_unstake :\n Raw_context.t ->\n for_next_cycle_use_only_after_slashing:bool ->\n Contract_repr.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** Staking can be either automated or manual. If Adaptive Issuance is\n enabled, staking must be manual. *)\ntype staking_automation = Auto_staking | Manual_staking\n\nval staking_automation : Raw_context.t -> staking_automation\n\nval check_manual_staking_allowed : Raw_context.t -> unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 | Cannot_stake_with_unfinalizable_unstake_requests_to_another_delegate\n | Manual_staking_forbidden\n\nlet () =\n let description =\n \"A contract tries to stake to its delegate while having unstake requests \\\n to a previous delegate that cannot be finalized yet. Try again in a later \\\n cycle (no more than consensus_rights_delay + max_slashing_period).\"\n in\n register_error_kind\n `Permanent\n ~id:\n \"operation.cannot_stake_with_unfinalizable_unstake_requests_to_another_delegate\"\n ~title:\n \"Cannot stake with unfinalizable unstake requests to another delegate\"\n ~description\n Data_encoding.unit\n (function\n | Cannot_stake_with_unfinalizable_unstake_requests_to_another_delegate ->\n Some ()\n | _ -> None)\n (fun () ->\n Cannot_stake_with_unfinalizable_unstake_requests_to_another_delegate) ;\n register_error_kind\n `Temporary\n ~id:\"operation.manual_staking_forbidden\"\n ~title:\"Manual staking operations are forbidden\"\n ~description:\n \"Manual staking operations are forbidden because staking is currently \\\n automated.\"\n Data_encoding.unit\n (function Manual_staking_forbidden -> Some () | _ -> None)\n (fun () -> Manual_staking_forbidden)\n\nlet perform_finalizable_unstake_transfers ctxt contract finalizable =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (ctxt, balance_updates) (delegate, cycle, amount) ->\n let+ ctxt, new_balance_updates =\n Token.transfer\n ctxt\n (`Unstaked_frozen_deposits\n (Unstaked_frozen_staker_repr.Single (contract, delegate), cycle))\n (`Contract contract)\n amount\n in\n (ctxt, new_balance_updates @ balance_updates))\n (ctxt, [])\n finalizable\n\n(* The [check_unfinalizable] function in argument must consume its gas, if\n relevant. *)\nlet finalize_unstake_and_check ~for_next_cycle_use_only_after_slashing\n ~check_unfinalizable ctxt contract =\n let open Lwt_result_syntax in\n let*? ctxt =\n Raw_context.consume_gas\n ctxt\n Adaptive_issuance_costs.prepare_finalize_unstake_cost\n in\n let* prepared_opt =\n Unstake_requests_storage.prepare_finalize_unstake\n ~for_next_cycle_use_only_after_slashing\n ctxt\n contract\n in\n match prepared_opt with\n | None -> return (ctxt, [], None)\n | Some {finalizable; unfinalizable} -> (\n let* ctxt = check_unfinalizable ctxt unfinalizable in\n match finalizable with\n | [] -> return (ctxt, [], Some unfinalizable)\n | _ ->\n (* We only update the unstake requests if the [finalizable] list is not empty.\n Indeed, if it is not empty, it means that at least one of the unstake operations\n will be finalized, and the storage needs to be updated accordingly.\n Conversely, if finalizable is empty, then [unfinalizable] contains\n all the previous unstake requests, that should remain as requests after this\n operation. *)\n let*? ctxt =\n Raw_context.consume_gas\n ctxt\n Adaptive_issuance_costs.finalize_unstake_and_check_cost\n in\n let* ctxt =\n Unstake_requests_storage.update ctxt contract unfinalizable\n in\n let* ctxt, balance_updates =\n perform_finalizable_unstake_transfers ctxt contract finalizable\n in\n return (ctxt, balance_updates, Some unfinalizable))\n\nlet finalize_unstake ctxt ~for_next_cycle_use_only_after_slashing contract =\n let open Lwt_result_syntax in\n let check_unfinalizable ctxt _unfinalizable = return ctxt in\n let* ctxt, balance_updates, _ =\n finalize_unstake_and_check\n ~for_next_cycle_use_only_after_slashing\n ~check_unfinalizable\n ctxt\n contract\n in\n return (ctxt, balance_updates)\n\nlet can_stake_from_unstake ctxt ~for_next_cycle_use_only_after_slashing\n ~delegate =\n let open Lwt_result_syntax in\n let* slashing_history_opt = Storage.Slashed_deposits.find ctxt delegate in\n let slashing_history = Option.value slashing_history_opt ~default:[] in\n\n let* slashing_history_opt_o =\n Storage.Contract.Slashed_deposits__Oxford.find\n ctxt\n (Contract_repr.Implicit delegate)\n in\n let slashing_history_o =\n Option.value slashing_history_opt_o ~default:[]\n |> List.map (fun (a, b) -> (a, Percentage.convert_from_o_to_p b))\n in\n\n let slashing_history = slashing_history @ slashing_history_o in\n\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let current_cycle =\n if for_next_cycle_use_only_after_slashing then Cycle_repr.succ current_cycle\n else current_cycle\n in\n let slashable_deposits_period =\n Constants_storage.slashable_deposits_period ctxt\n in\n let oldest_slashable_cycle =\n Cycle_repr.sub current_cycle (slashable_deposits_period + 1)\n |> Option.value ~default:Cycle_repr.root\n in\n let*! is_denounced =\n Pending_denunciations_storage.has_pending_denunciations ctxt delegate\n in\n let is_slashed =\n List.exists\n (fun (x, _) -> Cycle_repr.(x >= oldest_slashable_cycle))\n slashing_history\n in\n return @@ not (is_denounced || is_slashed)\n\nlet stake_from_unstake_for_delegate ctxt ~for_next_cycle_use_only_after_slashing\n ~delegate ~unfinalizable_requests_opt amount =\n let open Lwt_result_syntax in\n let remove_from_unstaked_frozen_deposit ctxt cycle delegate sender_contract\n amount =\n let* ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Unstaked_frozen_deposits\n (Unstaked_frozen_staker_repr.Single (sender_contract, delegate), cycle))\n (`Frozen_deposits\n (Frozen_staker_repr.single_staker ~staker:sender_contract ~delegate))\n amount\n in\n let* ctxt =\n Unstaked_frozen_deposits_storage\n .decrease_initial_amount_only_for_stake_from_unstake\n ctxt\n delegate\n cycle\n amount\n in\n return (ctxt, balance_updates)\n in\n match unfinalizable_requests_opt with\n | None -> return (ctxt, [], amount)\n | Some Unstake_requests_storage.{delegate = delegate_requests; requests} ->\n if\n Signature.Public_key_hash.(delegate <> delegate_requests)\n && not (List.is_empty requests)\n then (* Should not be possible *)\n return (ctxt, [], Tez_repr.zero)\n else\n let* allowed =\n can_stake_from_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing\n ~delegate\n in\n if not allowed then\n (* a slash could have modified the unstaked frozen deposits: cannot stake from unstake *)\n return (ctxt, [], amount)\n else\n let sender_contract = Contract_repr.Implicit delegate in\n let requests_sorted =\n List.sort\n (fun (cycle1, _) (cycle2, _) ->\n Cycle_repr.compare cycle2 cycle1\n (* decreasing cycle order, to release first the tokens\n that would be frozen for the longest time *))\n requests\n in\n let rec transfer_from_unstake ctxt balance_updates\n remaining_amount_to_transfer updated_requests_rev requests =\n if Tez_repr.(remaining_amount_to_transfer = zero) then\n return\n ( ctxt,\n balance_updates,\n Tez_repr.zero,\n List.rev_append requests updated_requests_rev )\n else\n match requests with\n | [] ->\n return\n ( ctxt,\n balance_updates,\n remaining_amount_to_transfer,\n updated_requests_rev )\n | (cycle, requested_amount) :: t ->\n if Tez_repr.(remaining_amount_to_transfer >= requested_amount)\n then\n let* ctxt, cycle_balance_updates =\n remove_from_unstaked_frozen_deposit\n ctxt\n cycle\n delegate\n sender_contract\n requested_amount\n in\n let*? remaining_amount =\n Tez_repr.(\n remaining_amount_to_transfer -? requested_amount)\n in\n transfer_from_unstake\n ctxt\n (balance_updates @ cycle_balance_updates)\n remaining_amount\n updated_requests_rev\n t\n else\n let* ctxt, cycle_balance_updates =\n remove_from_unstaked_frozen_deposit\n ctxt\n cycle\n delegate\n sender_contract\n remaining_amount_to_transfer\n in\n let*? new_requested_amount =\n Tez_repr.(\n requested_amount -? remaining_amount_to_transfer)\n in\n return\n ( ctxt,\n balance_updates @ cycle_balance_updates,\n Tez_repr.zero,\n List.rev_append\n t\n ((cycle, new_requested_amount) :: updated_requests_rev)\n )\n in\n let* ( ctxt,\n balance_updates,\n remaining_amount_to_transfer,\n updated_requests_rev ) =\n transfer_from_unstake ctxt [] amount [] requests_sorted\n in\n let updated_requests = List.rev updated_requests_rev in\n let* ctxt =\n Unstake_requests_storage.update\n ctxt\n sender_contract\n {delegate; requests = updated_requests}\n in\n return (ctxt, balance_updates, remaining_amount_to_transfer)\n\nlet stake ctxt ~for_next_cycle_use_only_after_slashing\n ~(amount : [`At_most of Tez_repr.t | `Exactly of Tez_repr.t]) ~sender\n ~delegate =\n let open Lwt_result_syntax in\n let check_unfinalizable ctxt\n Unstake_requests_storage.{delegate = unstake_delegate; requests} =\n match (requests, amount) with\n | [], _ | _ :: _, `At_most _ -> return ctxt\n | _ :: _, `Exactly _ ->\n if Signature.Public_key_hash.(delegate <> unstake_delegate) then\n tzfail\n Cannot_stake_with_unfinalizable_unstake_requests_to_another_delegate\n else return ctxt\n in\n let sender_contract = Contract_repr.Implicit sender in\n let* ctxt, finalize_balance_updates, unfinalizable_requests_opt =\n finalize_unstake_and_check\n ~check_unfinalizable\n ctxt\n ~for_next_cycle_use_only_after_slashing\n sender_contract\n in\n let tez_amount =\n match amount with `Exactly amount | `At_most amount -> amount\n in\n (* stake from unstake for eligible delegates *)\n let* ctxt, stake_balance_updates1, amount_from_liquid =\n if Signature.Public_key_hash.(sender <> delegate) then\n return (ctxt, [], tez_amount)\n else\n stake_from_unstake_for_delegate\n ctxt\n ~for_next_cycle_use_only_after_slashing\n ~delegate\n ~unfinalizable_requests_opt\n tez_amount\n in\n (* Get amount to transfer from liquid wrt mode *)\n let* amount_from_liquid =\n match amount with\n | `Exactly _ -> return amount_from_liquid\n | `At_most _ ->\n let* spendable =\n Contract_storage.get_balance ctxt (Implicit delegate)\n in\n return Tez_repr.(min amount_from_liquid spendable)\n in\n (* Issue pseudotokens for delegators *)\n let* ctxt, stake_balance_updates2 =\n if Signature.Public_key_hash.(sender <> delegate) then\n Staking_pseudotokens_storage.stake\n ctxt\n ~contract:sender_contract\n ~delegate\n amount_from_liquid\n else return (ctxt, [])\n in\n let+ ctxt, stake_balance_updates3 =\n Token.transfer\n ctxt\n (`Contract sender_contract)\n (`Frozen_deposits\n (Frozen_staker_repr.single_staker ~staker:sender_contract ~delegate))\n amount_from_liquid\n in\n ( ctxt,\n stake_balance_updates1 @ stake_balance_updates2 @ stake_balance_updates3\n @ finalize_balance_updates )\n\nlet request_unstake ctxt ~for_next_cycle_use_only_after_slashing\n ~sender_contract ~delegate requested_amount =\n let open Lwt_result_syntax in\n let* ctxt, tez_to_unstake, request_unstake_balance_updates =\n Staking_pseudotokens_storage.request_unstake\n ctxt\n ~contract:sender_contract\n ~delegate\n requested_amount\n in\n if Tez_repr.(tez_to_unstake = zero) then\n return (ctxt, request_unstake_balance_updates)\n else\n let*? ctxt =\n Raw_context.consume_gas ctxt Adaptive_issuance_costs.request_unstake_cost\n in\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let concerned_cycle =\n if for_next_cycle_use_only_after_slashing then\n Cycle_repr.succ current_cycle\n else current_cycle\n in\n let* ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Frozen_deposits\n (Frozen_staker_repr.single_staker ~staker:sender_contract ~delegate))\n (`Unstaked_frozen_deposits\n ( Unstaked_frozen_staker_repr.Single (sender_contract, delegate),\n concerned_cycle ))\n tez_to_unstake\n in\n let* ctxt, finalize_balance_updates =\n finalize_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing\n sender_contract\n in\n let+ ctxt =\n Unstake_requests_storage.add\n ctxt\n ~contract:sender_contract\n ~delegate\n concerned_cycle\n tez_to_unstake\n in\n ( ctxt,\n request_unstake_balance_updates @ balance_updates\n @ finalize_balance_updates )\n\ntype staking_automation = Auto_staking | Manual_staking\n\nlet staking_automation ctxt =\n if\n Raw_context.adaptive_issuance_enable ctxt\n || not (Constants_storage.adaptive_issuance_autostaking_enable ctxt)\n then Manual_staking\n else Auto_staking\n\nlet check_manual_staking_allowed ctxt =\n let open Result_syntax in\n match staking_automation ctxt with\n | Manual_staking -> return_unit\n | Auto_staking -> error Manual_staking_forbidden\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 attesting 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] 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, consensus_rights_delay]. It also freezes the deposits for all\n the active delegates. *)\nval init_first_cycles : Raw_context.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\nlet update_activity ctxt last_cycle =\n let open Lwt_result_syntax in\n let rights_delay = Constants_storage.consensus_rights_delay ctxt in\n match Cycle_repr.sub last_cycle rights_delay with\n | None ->\n (* do not update activity in the first cycles of a network.*)\n return (ctxt, [])\n | Some _unfrozen_cycle ->\n Stake_storage.fold_on_active_delegates_with_minimal_stake_s\n ctxt\n ~order:`Sorted\n ~init:(Ok (ctxt, []))\n ~f:(fun delegate acc ->\n let*? ctxt, deactivated = acc in\n let* cycle =\n Delegate_activation_storage.last_cycle_before_deactivation\n ctxt\n delegate\n in\n if Cycle_repr.(cycle <= last_cycle) then\n let*! ctxt = Stake_storage.set_inactive ctxt delegate in\n return (ctxt, delegate :: deactivated)\n else return (ctxt, deactivated))\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_attesting_rewards ctxt last_cycle unrevealed_nonces =\n let open Lwt_result_syntax in\n let*? attesting_reward_per_slot =\n Delegate_rewards.attesting_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 let* total_active_stake =\n Stake_storage.get_total_active_stake ctxt last_cycle\n in\n let total_active_stake_weight =\n Stake_repr.staking_weight total_active_stake\n in\n let* delegates = Stake_storage.get_selected_distribution ctxt last_cycle in\n List.fold_left_es\n (fun (ctxt, balance_updates) (delegate, active_stake) ->\n let* ctxt, sufficient_participation =\n Delegate_missed_attestations_storage\n .check_and_reset_delegate_participation\n ctxt\n delegate\n in\n let has_revealed_nonces =\n delegate_has_revealed_nonces delegate unrevealed_nonces_set\n in\n let active_stake_weight = Stake_repr.staking_weight active_stake in\n let expected_slots =\n Delegate_missed_attestations_storage\n .expected_slots_for_given_active_stake\n ctxt\n ~total_active_stake_weight\n ~active_stake_weight\n in\n let rewards = Tez_repr.mul_exn attesting_reward_per_slot expected_slots in\n if sufficient_participation && has_revealed_nonces then\n (* Sufficient participation: we pay the rewards *)\n let+ ctxt, payed_rewards_receipts =\n Shared_stake.pay_rewards\n ctxt\n ~active_stake\n ~source:`Attesting_rewards\n ~delegate\n rewards\n in\n (ctxt, payed_rewards_receipts @ balance_updates)\n else\n (* Insufficient participation or unrevealed nonce: no rewards *)\n let+ ctxt, payed_rewards_receipts =\n Token.transfer\n ctxt\n `Attesting_rewards\n (`Lost_attesting_rewards\n (delegate, not sufficient_participation, not has_revealed_nonces))\n rewards\n in\n (ctxt, payed_rewards_receipts @ balance_updates))\n (ctxt, [])\n delegates\n\nlet adjust_frozen_stakes ctxt ~deactivated_delegates :\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t =\n let open Lwt_result_syntax in\n (* Note: deactivated_delegates have just been removed from the set of\n active delegates with minimal stake by [update_activity] so the two\n following iterations are on disjoint sets of delegates. *)\n let* ctxt, balance_updates =\n Stake_storage.fold_on_active_delegates_with_minimal_stake_es\n ctxt\n ~order:`Undefined\n ~init:(ctxt, [])\n ~f:(fun delegate (ctxt, balance_updates) ->\n let*! has_been_denounced =\n Pending_denunciations_storage.has_pending_denunciations ctxt delegate\n in\n if has_been_denounced then return (ctxt, balance_updates)\n (* we don't autostake on behalf of delegates who will be slashed *)\n else\n let* full_staking_balance =\n Stake_storage.get_full_staking_balance ctxt delegate\n in\n let own_frozen =\n Full_staking_balance_repr.own_frozen full_staking_balance\n in\n let*? optimal_frozen =\n Stake_context.optimal_frozen_wrt_delegated_without_ai\n ctxt\n full_staking_balance\n in\n let* deposit_limit =\n Delegate_storage.frozen_deposits_limit ctxt delegate\n in\n let optimal_frozen =\n match deposit_limit with\n | None -> optimal_frozen\n | Some deposit_limit -> Tez_repr.min optimal_frozen deposit_limit\n in\n let* ctxt, new_balance_updates =\n if Tez_repr.(optimal_frozen > own_frozen) then\n let*? optimal_to_stake =\n Tez_repr.(optimal_frozen -? own_frozen)\n in\n Staking.stake\n ctxt\n ~for_next_cycle_use_only_after_slashing:true\n ~amount:(`At_most optimal_to_stake)\n ~sender:delegate\n ~delegate\n else if Tez_repr.(optimal_frozen < own_frozen) then\n let*? to_unstake = Tez_repr.(own_frozen -? optimal_frozen) in\n Staking.request_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing:true\n ~sender_contract:Contract_repr.(Implicit delegate)\n ~delegate\n to_unstake\n else\n Staking.finalize_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing:true\n Contract_repr.(Implicit delegate)\n in\n return (ctxt, new_balance_updates @ balance_updates))\n in\n List.fold_left_es\n (fun (ctxt, balance_updates) delegate ->\n let+ ctxt, new_balance_updates =\n Staking.request_unstake\n ctxt\n ~for_next_cycle_use_only_after_slashing:true\n ~sender_contract:(Implicit delegate)\n ~delegate\n Tez_repr.max_mutez\n in\n (ctxt, new_balance_updates @ balance_updates))\n (ctxt, balance_updates)\n deactivated_delegates\n\nlet cycle_end ctxt last_cycle =\n let open Lwt_result_syntax in\n (* attributing attesting rewards *)\n let* ctxt, unrevealed_nonces = Seed_storage.cycle_end ctxt last_cycle in\n let* ctxt, attesting_balance_updates =\n distribute_attesting_rewards ctxt last_cycle unrevealed_nonces\n in\n (* Applying slashing related to expiring denunciations *)\n let* ctxt, slashing_balance_updates =\n Delegate_slashed_deposits_storage.apply_and_clear_denunciations ctxt\n in\n let new_cycle = Cycle_repr.add last_cycle 1 in\n let*! ctxt = Already_denounced_storage.clear_outdated_cycle ctxt ~new_cycle in\n (* Deactivating delegates which didn't participate to consensus for too long *)\n let* ctxt, deactivated_delegates = update_activity ctxt last_cycle in\n (* Applying autostaking. Do not move before slashing. Keep before rights\n computation for optimising rights*)\n let* ctxt, autostake_balance_updates =\n match Staking.staking_automation ctxt with\n | Manual_staking -> return (ctxt, [])\n | Auto_staking -> adjust_frozen_stakes ctxt ~deactivated_delegates\n in\n (* Computing future staking rights *)\n let* ctxt =\n Delegate_sampler.select_new_distribution_at_cycle_end ctxt ~new_cycle\n in\n (* Activating consensus key for the cycle to come *)\n let*! ctxt = Delegate_consensus_key.activate ctxt ~new_cycle in\n (* trying to unforbid delegates for the cycle to come. *)\n let* ctxt =\n Forbidden_delegates_storage.update_at_cycle_end_after_slashing\n ctxt\n ~new_cycle\n in\n (* clear deprecated cycles data. *)\n let* ctxt = Stake_storage.clear_at_cycle_end ctxt ~new_cycle in\n let* ctxt = Delegate_sampler.clear_outdated_sampling_data ctxt ~new_cycle in\n (* activate delegate parameters for the cycle to come. *)\n let*! ctxt = Delegate_staking_parameters.activate ctxt ~new_cycle in\n (* updating AI coefficient. It should remain after all balance changes of the\n cycle-end operations *)\n let* ctxt =\n Adaptive_issuance_storage.update_stored_rewards_at_cycle_end ctxt ~new_cycle\n in\n let balance_updates =\n slashing_balance_updates @ attesting_balance_updates\n @ autostake_balance_updates\n in\n return (ctxt, balance_updates, deactivated_delegates)\n\nlet init_first_cycles ctxt =\n let consensus_rights_delay = Constants_storage.consensus_rights_delay 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 Delegate_sampler.select_distribution_for_cycle ctxt cycle)\n ctxt\n Misc.(0 --> consensus_rights_delay)\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\n [Error (Storage_error Existing_key)] if 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\n(** Returns the voting power of a delegate from the voting power\n listings. This function does not account for gas cost. *)\nval get_voting_power_free :\n Raw_context.t -> Signature.public_key_hash -> int64 tzresult Lwt.t\n\n(** Same as [get_voting_power_free] but consumes gas. *)\nval get_voting_power :\n Raw_context.t ->\n Signature.public_key_hash ->\n (Raw_context.t * int64) tzresult Lwt.t\n\n(** Same as [get_voting_power_free] but computes the voting power\n based on the current stake of the delegate instead of reading it\n from the vote listings. *)\nval get_current_voting_power_free :\n Raw_context.t -> Signature.public_key_hash -> 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 let open Lwt_result_syntax in\n let+ value = Storage.Vote.Proposals_count.find ctxt proposer in\n Option.value ~default:0 value\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 let open Lwt_result_syntax in\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 let* weight = Storage.Vote.Listings.get ctxt delegate in\n let*? acc in\n let previous =\n match Protocol_hash.Map.find proposal acc with\n | None -> 0L\n | Some x -> x\n in\n return (Protocol_hash.Map.add proposal (Int64.add weight previous) acc))\n\nlet clear_proposals ctxt =\n let open Lwt_syntax in\n let* ctxt = Storage.Vote.Proposals_count.clear ctxt in\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 let open Lwt_result_syntax in\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 let* weight = Storage.Vote.Listings.get ctxt delegate in\n let count = Int64.add weight in\n let*? ballots in\n return\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 get_current_voting_power_free ctxt delegate =\n let open Lwt_result_syntax in\n let* stake = Storage.Stake.Staking_balance.get ctxt delegate in\n Lwt.return @@ Full_staking_balance_repr.voting_weight stake\n\nlet update_listings ctxt =\n let open Lwt_result_syntax in\n let*! ctxt = Storage.Vote.Listings.clear ctxt in\n let* ctxt, total =\n Stake_storage.fold_on_active_delegates_with_minimal_stake_es\n ctxt\n ~init:(ctxt, 0L)\n ~order:`Sorted\n ~f:(fun delegate (ctxt, total) ->\n let* weight = get_current_voting_power_free ctxt delegate in\n let+ ctxt = Storage.Vote.Listings.init ctxt delegate weight in\n (ctxt, Int64.add total weight))\n in\n let*! ctxt = Storage.Vote.Voting_power_in_listings.add ctxt total in\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 let open Lwt_result_syntax in\n let* voting_power = Storage.Vote.Listings.find ctxt delegate in\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 let* period = Voting_period_storage.get_current_kind ctxt in\n let* current_ballot =\n match period with\n | Exploration | Promotion -> Storage.Vote.Ballots.find ctxt delegate\n | Proposal | Cooldown | Adoption -> return_none\n in\n let*! current_proposals =\n match period with\n | Exploration | Promotion | Cooldown | Adoption -> Lwt.return_nil\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 in\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 let open Lwt_result_syntax in\n let+ value = Storage.Vote.Listings.find ctxt owner in\n Option.value ~default:0L value\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 Lwt_result_syntax in\n let open Raw_context in\n (* Always consume read access to memory *)\n (* Accessing an int64 at /votes/listings/<KeyKind>/<hash> *)\n let*? ctxt =\n consume_gas ctxt (Storage_costs.read_access ~path_length:4 ~read_bytes:8)\n in\n let+ power_opt = Storage.Vote.Listings.find ctxt owner in\n match power_opt with None -> (ctxt, 0L) | 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 Lwt_result_syntax in\n let open Raw_context in\n (* Accessing an int64 at /votes/total_voting_power *)\n let*? ctxt =\n consume_gas ctxt (Storage_costs.read_access ~path_length:2 ~read_bytes:8)\n in\n let+ total_voting_power = get_total_voting_power_free ctxt in\n (ctxt, total_voting_power)\n\nlet get_current_quorum ctxt =\n let open Lwt_result_syntax in\n let+ participation_ema = Storage.Vote.Participation_ema.get ctxt in\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 let open Lwt_result_syntax in\n (* participation EMA is in centile of a percentage *)\n let participation_ema = Constants_storage.quorum_max ctxt in\n let* ctxt = Storage.Vote.Participation_ema.init ctxt participation_ema in\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 let open Lwt_result_syntax in\n let+ ctxt, res = Storage.Ticket_balance.Table.find ctxt key in\n (res, ctxt)\n\nlet set_balance ctxt key balance =\n let cost_of_key = Z.of_int 65 in\n let open Lwt_result_syntax in\n let* () =\n fail_when\n Compare.Z.(balance < Z.zero)\n (Negative_ticket_balance {key; balance})\n in\n if Compare.Z.(balance = Z.zero) then\n let+ ctxt, freed, existed = Storage.Ticket_balance.Table.remove ctxt key in\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 let+ ctxt, size_diff, existed =\n Storage.Ticket_balance.Table.add ctxt key balance\n in\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 let open Lwt_result_syntax in\n let* res, ctxt = get_balance ctxt key in\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 let open Lwt_result_syntax in\n if Compare.Z.(storage_diff = Z.zero) then return (Z.zero, ctxt)\n else\n let* used_storage = Storage.Ticket_balance.Used_storage_space.find ctxt in\n let used_storage = Option.value ~default:Z.zero used_storage in\n let* paid_storage = Storage.Ticket_balance.Paid_storage_space.find ctxt in\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 let*? () =\n error_when\n Compare.Z.(new_used_storage < Z.zero)\n Used_storage_space_underflow\n in\n let*! ctxt =\n Storage.Ticket_balance.Used_storage_space.add ctxt new_used_storage\n in\n let diff = Z.sub new_used_storage paid_storage in\n if Compare.Z.(Z.zero < diff) then\n let*! ctxt =\n Storage.Ticket_balance.Paid_storage_space.add ctxt new_used_storage\n in\n return (diff, ctxt)\n else return (Z.zero, ctxt)\n\nmodule Internal_for_tests = struct\n let used_storage_space c =\n let open Lwt_result_syntax in\n let+ value = Storage.Ticket_balance.Used_storage_space.find c in\n Option.value ~default:Z.zero value\n\n let paid_storage_space c =\n let open Lwt_result_syntax in\n let+ value = Storage.Ticket_balance.Paid_storage_space.find c in\n Option.value ~default:Z.zero value\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 ~per_block_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 per_block_vote:Per_block_votes_repr.per_block_vote ->\n (Raw_context.t -> Contract_hash.t -> (Raw_context.t * 'a list) tzresult Lwt.t) ->\n (Raw_context.t * 'a list * Per_block_votes_repr.Liquidity_baking_toggle_EMA.t)\n tzresult\n 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 Per_block_votes_repr\n\nlet get_cpmm_address = Storage.Liquidity_baking.Cpmm_address.get\n\nlet get_toggle_ema ctxt =\n let open Lwt_result_syntax in\n let* ema = Storage.Liquidity_baking.Toggle_ema.get ctxt in\n Liquidity_baking_toggle_EMA.of_int32 ema\n\nlet on_cpmm_exists ctxt f =\n let open Lwt_result_syntax in\n let* cpmm_contract = get_cpmm_address ctxt in\n let*! exists =\n Contract_storage.exists ctxt (Contract_repr.Originated cpmm_contract)\n in\n match exists with\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 ~per_block_vote =\n let open Lwt_result_syntax in\n let* old_ema = get_toggle_ema ctxt in\n let new_ema = compute_new_liquidity_baking_ema ~per_block_vote old_ema in\n let+ ctxt =\n Storage.Liquidity_baking.Toggle_ema.update\n ctxt\n (Liquidity_baking_toggle_EMA.to_int32 new_ema)\n in\n (ctxt, new_ema)\n\nlet check_ema_below_threshold ctxt ema =\n Liquidity_baking_toggle_EMA.(\n ema < Constants_storage.liquidity_baking_toggle_ema_threshold ctxt)\n\nlet on_subsidy_allowed ctxt ~per_block_vote f =\n let open Lwt_result_syntax in\n let* ctxt, toggle_ema = update_toggle_ema ctxt ~per_block_vote in\n if check_ema_below_threshold ctxt toggle_ema then\n let+ ctxt, operation_results = on_cpmm_exists ctxt f in\n (ctxt, operation_results, toggle_ema)\n else return (ctxt, [], toggle_ema)\n" ;
} ;
{ name = "Liquidity_baking_cpmm" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2024 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\nlet 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 = "(*****************************************************************************)\n(* *)\n(* SPDX-License-Identifier: MIT *)\n(* Copyright (c) 2024 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(*****************************************************************************)\n\nlet 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 let open Lwt_result_syntax in\n let* ctxt =\n Contract_storage.raw_originate\n ctxt\n ~prepaid_bootstrap_storage:true\n address_hash\n ~script\n in\n let address = Contract_repr.Originated address_hash in\n let* size = Contract_storage.used_storage_space ctxt address in\n let* ctxt, _, origination_updates =\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 in\n let* ctxt, _, storage_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 in\n let* ctxt, transfer_updates =\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n `Liquidity_baking_subsidies\n (`Contract address)\n balance\n in\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 let open Lwt_result_syntax in\n let*? ctxt, fa12_address =\n Contract_storage.fresh_contract_from_current_nonce ctxt\n in\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 let* script, ctxt = typecheck ctxt script in\n let+ ctxt, origination_result =\n originate\n ctxt\n fa12_address\n ~balance:(Tez_repr.of_mutez_exn 1_000_000L)\n script\n in\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 let open Lwt_result_syntax in\n let*! exists =\n Contract_storage.exists\n ctxt\n (Contract_repr.Originated mainnet_tzBTC_address)\n in\n if exists then\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 else if\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 Compare.Int32.(current_level < 1_437_862l)\n then\n let* ctxt, token_address, token_result =\n originate_test_fa12 ~typecheck ctxt first_bootstrap_account\n (* Token contract admin *)\n in\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 let open Lwt_result_syntax in\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 let* ctxt = Storage.Liquidity_baking.Toggle_ema.init ctxt 0l in\n let current_level =\n Raw_level_repr.to_int32 (Level_storage.current ctxt).level\n in\n let*? ctxt, cpmm_address =\n Contract_storage.fresh_contract_from_current_nonce ctxt\n in\n let*? ctxt, lqt_address =\n Contract_storage.fresh_contract_from_current_nonce ctxt\n in\n let* ctxt = Storage.Liquidity_baking.Cpmm_address.init ctxt cpmm_address in\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 let* cpmm_script, ctxt = typecheck ctxt cpmm_script in\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 let* lqt_script, ctxt = typecheck ctxt lqt_script in\n let* ctxt, cpmm_result =\n originate\n ctxt\n cpmm_address\n ~balance:(Tez_repr.of_mutez_exn 100L)\n cpmm_script\n in\n let+ ctxt, lqt_result =\n originate ctxt lqt_address ~balance:Tez_repr.zero lqt_script\n in\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_no_valid_commitment_to_cement\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_commitment_too_old of {\n last_cemented_inbox_level : Raw_level_repr.t;\n commitment_inbox_level : Raw_level_repr.t;\n }\n | (* `Temporary *)\n Sc_rollup_no_commitment_to_cement of Raw_level_repr.t\n | (* `Permanent *)\n Sc_rollup_double_publish of Sc_rollup_commitment_repr.Hash.t\n | Sc_rollup_empty_whitelist\n | Sc_rollup_whitelist_disabled\n | Sc_rollup_staker_not_in_whitelist\n | Sc_rollup_duplicated_key_in_whitelist\n | Sc_rollup_is_public\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 =\n \"Attempted to cement a commitment but there is no valid commitment to \\\n cement.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_no_valid_commitment_to_cement\"\n ~title:\"No valid commitment to cement\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_no_valid_commitment_to_cement -> Some () | _ -> None)\n (fun () -> Sc_rollup_no_valid_commitment_to_cement) ;\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\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 let description = \"No commitment to cement\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_no_commitment_to_cement\"\n ~title:description\n ~pp:(fun ppf inbox_level ->\n Format.fprintf\n ppf\n \"There is no commitment to cement at inbox level %a.\"\n Raw_level_repr.pp\n inbox_level)\n ~description\n Data_encoding.(obj1 (req \"inbox_level\" Raw_level_repr.encoding))\n (function\n | Sc_rollup_no_commitment_to_cement inbox_level -> Some inbox_level\n | _ -> None)\n (fun inbox_level -> Sc_rollup_no_commitment_to_cement inbox_level) ;\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_double_publish\"\n ~title:\"The commitment was published twice by the operator\"\n ~pp:(fun ppf commitment_hash ->\n Format.fprintf\n ppf\n \"The operator publishing %a already published this commitment.\"\n Sc_rollup_commitment_repr.Hash.pp\n commitment_hash)\n ~description\n Data_encoding.(\n obj1 (req \"commitment_hash\" Sc_rollup_commitment_repr.Hash.encoding))\n (function\n | Sc_rollup_double_publish commitment_hash -> Some commitment_hash\n | _ -> None)\n (fun commitment_hash -> Sc_rollup_double_publish commitment_hash) ;\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_empty_whitelist\"\n ~title:\"Invalid whitelist: whitelist cannot be empty\"\n ~description:\"Smart rollup whitelist cannot be empty\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Smart rollup whitelist cannot be empty.\")\n Data_encoding.empty\n (function Sc_rollup_empty_whitelist -> Some () | _ -> None)\n (fun () -> Sc_rollup_empty_whitelist) ;\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_whitelist_disabled\"\n ~title:\"Invalid whitelist: must be None when the feature is deactivated\"\n ~description:\"The whitelist must be None when the feature is deactivated.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Private smart rollup with whitelist ACL is disabled.\")\n Data_encoding.empty\n (function Sc_rollup_whitelist_disabled -> Some () | _ -> None)\n (fun () -> Sc_rollup_whitelist_disabled) ;\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_staker_not_in_whitelist\"\n ~title:description\n ~description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n \"The rollup is private and the submitter of the commitment is not \\\n present in the whitelist.\")\n Data_encoding.empty\n (function Sc_rollup_staker_not_in_whitelist -> Some () | _ -> None)\n (fun () -> Sc_rollup_staker_not_in_whitelist) ;\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_duplicated_key_in_whitelist\"\n ~title:description\n ~description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n \"The whitelist contains twice the same key. This is forbidden and all \\\n keys in the whitelist should be disctinct.\")\n Data_encoding.empty\n (function Sc_rollup_duplicated_key_in_whitelist -> Some () | _ -> None)\n (fun () -> Sc_rollup_duplicated_key_in_whitelist) ;\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_rollup_is_public\"\n ~title:description\n ~description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n \"The rollup is public, no update whitelist message can be executed.\")\n Data_encoding.empty\n (function Sc_rollup_is_public -> Some () | _ -> None)\n (fun () -> Sc_rollup_is_public)\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 tzresult Lwt.t\n\n(** Adds the [Info_per_level] in the in-memory inbox level witness. If\n the current level is the first level of the current protocol then\n also add [Migration] message. *)\nval add_level_info :\n predecessor:Block_hash.t -> Raw_context.t -> Raw_context.t tzresult 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 tzresult Lwt.t\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 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 Result_syntax in\n let open Sc_rollup_inbox_message_repr in\n List.fold_left_map_e\n (fun ctxt message ->\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_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 Store.Inbox.update ctxt inbox\n\nlet add_level_info ~predecessor ctxt =\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 current_level = (Raw_context.current_level ctxt).level in\n let+ first_level = Storage.Tenderbake.First_level_of_protocol.get ctxt in\n let is_first_level_of_protocol =\n (* first_level is set at the last block of a protocol, when mig is\n run. *)\n Int32.equal (Raw_level_repr.diff current_level first_level) 1l\n in\n let witness =\n if is_first_level_of_protocol then\n Sc_rollup_inbox_merkelized_payload_hashes_repr.add_payload_no_history\n witness\n Raw_context.protocol_migration_serialized_message\n else witness\n in\n Raw_context.Sc_rollup_in_memory_inbox.set_current_messages ctxt witness\n\nlet init_inbox ~predecessor ctxt =\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\n ~protocol_migration_message:\n Raw_context.protocol_migration_serialized_message\n ~predecessor_timestamp\n ~predecessor\n level\n in\n Store.Inbox.init ctxt inbox\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 = "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 let open Lwt_result_syntax in\n match inputs with\n | [] -> return (ctxt, Some state)\n | input :: inputs ->\n let* ctxt, nullifier_in_state =\n Sapling_storage.nullifiers_mem ctxt state Sapling.UTXO.(input.nf)\n in\n if nullifier_in_state then return (ctxt, None)\n else\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 let open Lwt_result_syntax in\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 let* pass = Sapling_storage.root_mem ctxt state transaction.root in\n if not pass then return (ctxt, None)\n else\n let+ ctxt, state_opt =\n check_and_update_nullifiers ctxt state transaction.inputs\n in\n match state_opt with\n | None -> (ctxt, None)\n | 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 ->\n 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_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, scripts 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 let open Lwt_result_syntax in\n let* context, value = Storage.Global_constants.Map.find context hash in\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 open Result_syntax in\n let lexpr = Script_repr.lazy_expr expr in\n let* context =\n Raw_context.consume_gas context @@ Script_repr.force_bytes_cost lexpr\n in\n let* b = Script_repr.force_bytes lexpr in\n let+ context =\n Raw_context.consume_gas context\n @@ Gas_costs.expr_to_address_in_context_cost b\n in\n (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 let open Lwt_result_syntax in\n let*? context =\n Raw_context.consume_gas\n context\n (Gas_costs.expand_no_constants_branch_cost node)\n in\n let* context, node, did_expansion =\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 let*? context =\n Raw_context.consume_gas\n context\n Gas_costs.expand_constants_branch_cost\n in\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 let*? context =\n Raw_context.consume_gas\n context\n (Gas_costs.expand_no_constants_branch_cost node)\n in\n k (context, map, true) node\n | None ->\n let* context, expr = get context hash in\n (* Charge traversing the newly retrieved node *)\n let node = root expr in\n let*? context =\n Raw_context.consume_gas\n context\n (Gas_costs.expand_no_constants_branch_cost node)\n in\n k (context, Expr_hash_map.add hash node map, true) node)\n )\n | _ -> tzfail Badly_formed_constant_expression)\n | Int _ | String _ | Bytes _ | Prim _ | Seq _ ->\n k (context, map, did_expansion) node)\n in\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 let open Lwt_result_syntax in\n let+ context, node = expand_node context (root expr) in\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 Result_syntax.tzfail 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 let open Lwt_result_syntax in\n let* context, node = expand_node context (root value) in\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 let*? (_depth : int) = check_depth node in\n let*? context, key = expr_to_address_in_context context value in\n let+ context, size =\n trace Expression_already_registered\n @@ Storage.Global_constants.Map.init context key value\n in\n (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 = "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(** [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 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_whitelist_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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_whitelist_repr\n\n(** [is_private context rollup] returns true if and only if the [rollup]\n is private, along with the new context accounting for the gas consumption\n of the function call. *)\nval is_private :\n Raw_context.t -> Sc_rollup_repr.t -> (Raw_context.t * bool) tzresult Lwt.t\n\n(** [init context rollup ~whitelist] returns the new context resulting from\n the addition of the elements of [whitelist] to the whitelist in the given\n [rollup]'s storage, along with the used storage space. *)\nval init :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n whitelist:t ->\n origination_level:Raw_level_repr.t ->\n (Raw_context.t * Z.t) tzresult Lwt.t\n\n(** [check_access_to_private_rollup context rollup staker_pkh] returns an error\n if [staker_pkh] is not in the whitelist of [rollup] if the [rollup] is marked\n as private. Returns the gas consumed by performing the call otherwise.\n Assumes the private rollup feature is activated. *)\nval check_access_to_private_rollup :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Signature.public_key_hash ->\n Raw_context.t tzresult Lwt.t\n\n(** [find_whitelist_uncarbonated context rollup] returns the whitelist from the storage. *)\nval find_whitelist_uncarbonated :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Signature.public_key_hash list option tzresult Lwt.t\n\n(** [replace context rollup ~whitelist] replaces the whitelist of\n [rollup] in the storage by [whitelist]. Returns the resulting\n context along with the used storage space. *)\nval replace :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n whitelist:t ->\n (Raw_context.t * Z.t) tzresult Lwt.t\n\n(** [make_public context rollup] removes the whitelist of [rollup] from\n the storage thus making the rollup public. Returns the resulting\n context along with the freed storage space. *)\nval make_public :\n Raw_context.t -> Sc_rollup_repr.t -> (Raw_context.t * Z.t) tzresult Lwt.t\n\n(** [adjust_storage_space ctxt ~new_storage_size] updates the used\n storage space for the whitelist according to\n [new_storage_size]. The additional positive amount of unpaid\n storage is returned. If no unpaid storage is consumed, this amount\n is 0.\n\n Note that when storage space for the whitelist 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 ->\n Sc_rollup_repr.t ->\n new_storage_size:Z.t ->\n (Raw_context.t * Z.t) tzresult Lwt.t\n\n(** [get_last_whitelist_update ctxt rollup] returns the pair (outbox level,\n message index) of the latest message of update to the whitelist. Returns\n None if no whitelist update has been applied. The returned context accounts\n for the gas consumption of the storage's update. *)\nval get_last_whitelist_update :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Raw_context.t * last_whitelist_update) tzresult Lwt.t\n\n(** [set_last_whitelist_update ctxt rollup (outbox_level, message_index)] set\n the outbox level and message index of the latest message of update to the\n whitelist. Returns the new context, and the difference from the old (maybe 0)\n to the new size of the underlying storage. *)\nval set_last_whitelist_update :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n last_whitelist_update ->\n (Raw_context.t * Z.t) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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_private ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt, rollup_is_public =\n Storage.Sc_rollup.Whitelist.is_empty (ctxt, rollup)\n in\n return (ctxt, not rollup_is_public)\n\nlet init_whitelist ctxt rollup_address ~whitelist =\n let open Lwt_result_syntax in\n let* ctxt, used_storage =\n List.fold_left_es\n (fun (ctxt, size) e ->\n let* ctxt, size_e =\n (* the storage fails when there key already exists. This is\n only to improve the UX so that it returns a cleaner\n error. *)\n trace Sc_rollup_errors.Sc_rollup_duplicated_key_in_whitelist\n @@ Storage.Sc_rollup.Whitelist.init (ctxt, rollup_address) e\n in\n return (ctxt, Z.add size (Z.of_int size_e)))\n (ctxt, Z.zero)\n whitelist\n in\n return (ctxt, used_storage)\n\nlet init ctxt rollup_address ~whitelist ~origination_level =\n let open Lwt_result_syntax in\n let* ctxt, used_storage = init_whitelist ctxt rollup_address ~whitelist in\n let* ctxt, _whitelist_update_storage =\n Storage.Sc_rollup.Last_whitelist_update.init\n ctxt\n rollup_address\n {outbox_level = origination_level; message_index = Z.zero}\n in\n return (ctxt, used_storage)\n\nlet check_access_to_private_rollup ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, rollup_is_private = is_private ctxt rollup in\n if rollup_is_private then\n let* ctxt, staker_in_whitelist =\n Storage.Sc_rollup.Whitelist.mem (ctxt, rollup) staker\n in\n let* () =\n fail_when\n (not staker_in_whitelist)\n Sc_rollup_errors.Sc_rollup_staker_not_in_whitelist\n in\n return ctxt\n else return ctxt\n\nlet find_whitelist_uncarbonated ctxt rollup_address =\n let open Lwt_result_syntax in\n let* _, is_private = is_private ctxt rollup_address in\n if is_private then\n let*! elts =\n Storage.Sc_rollup.Whitelist.fold_keys_unaccounted\n (ctxt, rollup_address)\n ~order:`Sorted\n ~init:[]\n ~f:(fun pkh acc -> Lwt.return (pkh :: acc))\n in\n return (Some elts)\n else return None\n\nlet replace ctxt rollup ~whitelist =\n let open Lwt_result_syntax in\n let* ctxt = Storage.Sc_rollup.Whitelist.clear (ctxt, rollup) in\n init_whitelist ~whitelist ctxt rollup\n\nlet make_public ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt = Storage.Sc_rollup.Whitelist.clear (ctxt, rollup) in\n let* used_storage =\n Storage.Sc_rollup.Whitelist_used_storage_space.find ctxt rollup\n in\n let used_storage = Option.value ~default:Z.zero used_storage in\n let*! ctxt =\n Storage.Sc_rollup.Whitelist_used_storage_space.remove ctxt rollup\n in\n return (ctxt, used_storage)\n\nlet adjust_storage_space ctxt rollup ~new_storage_size =\n let open Lwt_result_syntax in\n let* used_storage =\n Storage.Sc_rollup.Whitelist_used_storage_space.find ctxt rollup\n in\n let used_storage = Option.value ~default:Z.zero used_storage in\n let storage_diff = Z.sub new_storage_size used_storage in\n if Compare.Z.(storage_diff = Z.zero) then return (ctxt, Z.zero)\n else\n let*! ctxt =\n Storage.Sc_rollup.Whitelist_used_storage_space.add\n ctxt\n rollup\n new_storage_size\n in\n let* paid_storage =\n Storage.Sc_rollup.Whitelist_paid_storage_space.find ctxt rollup\n in\n let paid_storage = Option.value ~default:Z.zero paid_storage in\n let diff = Z.sub new_storage_size paid_storage in\n if Compare.Z.(Z.zero < diff) then\n let*! ctxt =\n Storage.Sc_rollup.Whitelist_paid_storage_space.add\n ctxt\n rollup\n new_storage_size\n in\n return (ctxt, diff)\n else return (ctxt, Z.zero)\n\nlet get_last_whitelist_update = Storage.Sc_rollup.Last_whitelist_update.get\n\n(** TODO: https://gitlab.com/tezos/tezos/-/issues/6186\n Do not consider storage diffs for small updates to the storage. *)\nlet set_last_whitelist_update ctxt rollup update =\n let open Lwt_result_syntax in\n let* ctxt, diff_size, _ =\n Storage.Sc_rollup.Last_whitelist_update.add ctxt rollup update\n in\n return (ctxt, Z.of_int diff_size)\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 ?whitelist 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 ?whitelist:Sc_rollup_whitelist_repr.t ->\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(** [raw_originate ?whitelist context ~kind ~parameters_ty ~genesis_commitment ~address] is\n exactly {!originate} but provides the rollup's address ([address]) instead\n of randomly generating it.\n\n This should not be used by [apply.ml], this is needed for bootstrap\n smart rollups only.\n*)\nval raw_originate :\n ?whitelist:Sc_rollup_whitelist_repr.t ->\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 address:Sc_rollup_repr.Address.t ->\n (Z.t * Sc_rollup_commitment_repr.Hash.t * Raw_context.t) tzresult 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\n(** [set_previous_commitment_period ctxt previous_period] is expected to be\n called during the protocol stitching, to ensure the previous commitment\n period length remains available in the next protocol, in order to deal\n with the commitments posted during the previous protocol but not yet\n cemented. *)\nval set_previous_commitment_period : Raw_context.t -> int -> Raw_context.t Lwt.t\n\n(** [previous_protocol_constants ctxt] fetches from [ctxt] the first level\n of the current protocol and the previous commitment period.\n\n Both values are bounded in size and small, so we don\226\128\153t carbonate the\n call.\n\n {b Warning: b} This function requires that the previous commitment\n period has been correctly set with {!set_previous_commitment_period}\n during the latest stitching. *)\nval previous_protocol_constants :\n Raw_context.t -> (Raw_level_repr.t * int) 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(** [new_address ctxt] produces an address completely\n determined by an operation hash and an origination counter, and\n accounts for gas spent. *)\nlet new_address ctxt =\n let open Result_syntax in\n let* ctxt, nonce = Raw_context.increment_origination_nonce ctxt 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 -> tzfail 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 init_genesis_info ctxt address genesis_commitment =\n let open Lwt_result_syntax in\n let*? ctxt, commitment_hash =\n Sc_rollup_commitment_storage.hash ctxt genesis_commitment\n in\n (* The [genesis_commitment.inbox_level] is equal to the current level. *)\n let genesis_info : Commitment.genesis_info =\n {commitment_hash; level = genesis_commitment.inbox_level}\n in\n let* ctxt, size = Store.Genesis_info.init ctxt address genesis_info in\n return (ctxt, genesis_info, size)\n\nlet init_commitment_storage ctxt address\n ({commitment_hash = genesis_commitment_hash; level = origination_level} :\n Commitment.genesis_info) genesis_commitment =\n let open Lwt_result_syntax in\n let* ctxt, lcc_size =\n Store.Last_cemented_commitment.init ctxt address genesis_commitment_hash\n in\n let* ctxt, commitment_size_diff =\n Store.Commitments.init\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 =\n Store.Commitment_added.init\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 =\n Store.Commitment_first_publication_level.init\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 return\n ( ctxt,\n lcc_size + commitment_size_diff + commitment_added_size_diff\n + commitment_first_publication_level_diff\n + commitments_per_inbox_level_diff )\n\nlet check_whitelist ctxt whitelist =\n let open Result_syntax in\n match whitelist with\n | Some whitelist ->\n let private_enabled = Constants_storage.sc_rollup_private_enable ctxt in\n (* The whitelist must be None when the feature is deactivated. *)\n let* () =\n error_unless\n private_enabled\n Sc_rollup_errors.Sc_rollup_whitelist_disabled\n in\n (* The origination fails with an empty list. *)\n error_when\n (List.is_empty whitelist)\n Sc_rollup_errors.Sc_rollup_empty_whitelist\n | None -> Ok ()\n\nlet raw_originate ?whitelist ctxt ~kind ~parameters_ty ~genesis_commitment\n ~address =\n let open Lwt_result_syntax in\n let*? () = check_whitelist ctxt whitelist in\n let* ctxt, pvm_kind_size = Store.PVM_kind.init ctxt address kind in\n let* ctxt, param_ty_size =\n Store.Parameters_type.init ctxt address parameters_ty\n in\n let* ctxt = Sc_rollup_staker_index_storage.init ctxt address in\n let* ctxt, genesis_info, genesis_info_size_diff =\n init_genesis_info ctxt address genesis_commitment\n in\n let* ctxt, commitment_size_diff =\n init_commitment_storage ctxt address genesis_info genesis_commitment\n in\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/4551\n There is no need to have both `origination_size` and the size of storage.\n We should remove one of them. *)\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* ctxt, whitelist_size =\n let*? () = check_whitelist ctxt whitelist in\n match whitelist with\n | Some whitelist ->\n let* ctxt, new_storage_size =\n Sc_rollup_whitelist_storage.init\n ~whitelist\n ctxt\n address\n ~origination_level:genesis_info.level\n in\n Sc_rollup_whitelist_storage.adjust_storage_space\n ctxt\n address\n ~new_storage_size\n | None -> return (ctxt, Z.zero)\n in\n let size =\n Z.(\n add\n (of_int\n (origination_size + stored_kind_size + addresses_size + param_ty_size\n + pvm_kind_size + genesis_info_size_diff + commitment_size_diff))\n whitelist_size)\n in\n return (size, genesis_info.commitment_hash, ctxt)\n\nlet originate ?whitelist ctxt ~kind ~parameters_ty ~genesis_commitment =\n let open Lwt_result_syntax in\n let*? ctxt, address = new_address ctxt in\n let* size, genesis_commitment, ctxt =\n raw_originate\n ?whitelist\n ctxt\n ~kind\n ~parameters_ty\n ~genesis_commitment\n ~address\n in\n return (address, size, genesis_commitment, 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_result_syntax in\n let*! res = Store.PVM_kind.keys_unaccounted ctxt in\n 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, exists = Store.Genesis_info.mem ctxt rollup in\n if exists then return ctxt else tzfail (Sc_rollup_does_not_exist rollup)\n\nlet set_previous_commitment_period ctxt value =\n Storage.Sc_rollup.Previous_commitment_period.add ctxt value\n\nlet previous_protocol_constants ctxt =\n let open Lwt_result_syntax in\n let* activation_level =\n Storage.Sc_rollup.Parisb2_activation_level.find ctxt\n in\n let* previous_commitment_period =\n Storage.Sc_rollup.Previous_commitment_period.get ctxt\n in\n return\n ( Option.value ~default:Raw_level_repr.root activation_level,\n previous_commitment_period )\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 context rollup] tries to cement the next inbox level commitment,\n that is, the LCC's successor. Returns the cemented commitment hash and\n its hash.\n\n For cementing to succeed, we need to have **one** commitment respecting\n the following properties:\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 found 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 (Raw_context.t\n * Sc_rollup_commitment_repr.t\n * Sc_rollup_commitment_repr.Hash.t)\n tzresult\n 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 sc_rollup_max_lookahead =\n Constants_storage.sc_rollup_max_lookahead_in_blocks ctxt\n in\n let* () =\n fail_when\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* last_proto_activation_level, last_commitment_period =\n Sc_rollup_storage.previous_protocol_constants ctxt\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 last_proto_expected_level =\n Raw_level_repr.(add pred_level last_commitment_period)\n in\n let expected_level =\n if Raw_level_repr.(last_proto_expected_level < last_proto_activation_level)\n then last_proto_expected_level\n else\n Raw_level_repr.add\n pred_level\n Constants_storage.(sc_rollup_commitment_period_in_blocks ctxt)\n in\n let* () =\n fail_unless\n Raw_level_repr.(commitment.inbox_level = expected_level)\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 let+ () =\n fail_when\n Compare.Int32.(\n Raw_level_repr.diff current_level oldest_commit\n > refutation_deadline_blocks)\n Sc_rollup_commitment_past_curfew\n in\n (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 let* () =\n (* Publishing the same commitment is not an issue. However, this causes\n a bad UX as operators can publish twice by mistake and pay twice\n the fees. *)\n fail_when\n Compare.Int.(size_diff_commitment_stakers = 0)\n (Sc_rollup_double_publish commitment_hash)\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* ctxt =\n if Constants_storage.sc_rollup_private_enable ctxt then\n Sc_rollup_whitelist_storage.check_access_to_private_rollup\n ctxt\n rollup\n staker\n else return ctxt\n 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 let commitment =\n if Compare.List_length_with.(active_stakers_index > 0) then\n Some commitment\n else None\n in\n return (ctxt, commitment)\n else (* Dangling commitment. *)\n return (ctxt, None)\n\nlet cementable_candidate_commitment_of_inbox_level ctxt rollup ~old_lcc\n 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 let rec collect_commitments ctxt candidate_commitment_res dangling_commitments\n = function\n | [] -> return (ctxt, candidate_commitment_res, dangling_commitments)\n | candidate_commitment_hash :: rst -> (\n let* ctxt, candidate_commitment =\n is_cementable_candidate_commitment\n ctxt\n rollup\n old_lcc\n candidate_commitment_hash\n in\n match (candidate_commitment, candidate_commitment_res) with\n | Some _, Some _ ->\n (* Second candidate commitment to cement, the inbox level is disputed. *)\n tzfail Sc_rollup_disputed\n | Some candidate_commitment, None ->\n (* First candidate commitment to cement, it becomes the result. *)\n collect_commitments\n ctxt\n (Some (candidate_commitment, candidate_commitment_hash))\n dangling_commitments\n rst\n | None, _ ->\n collect_commitments\n ctxt\n candidate_commitment_res\n (candidate_commitment_hash :: dangling_commitments)\n rst)\n in\n collect_commitments ctxt None [] commitments\n\n(** [find_commitment_to_cement ctxt rollup ~old_lcc new_lcc_level] tries to find\n the commitment to cement at inbox level [new_lcc_level].\n\n A commitment can be cemented if:\n {ol\n {li The commitment's predecessor is the LCC.}\n {li The challenge window period is over.}\n {li The commitment is the only active commitment.}\n }\n*)\nlet find_commitment_to_cement ctxt rollup ~old_lcc new_lcc_level =\n let open Lwt_result_syntax in\n (* Checks that the commitment is the only active commitment. *)\n let* ctxt, candidate_commitment, dangling_commitments =\n cementable_candidate_commitment_of_inbox_level\n ctxt\n rollup\n ~old_lcc\n new_lcc_level\n in\n match candidate_commitment with\n (* A commitment can be cemented if there is only one valid\n commitment. *)\n | Some (candidate_commitment, candidate_commitment_hash) ->\n let* ctxt, candidate_commitment_added =\n Store.Commitment_added.get (ctxt, rollup) candidate_commitment_hash\n in\n (* Checks that the commitment is past the challenge window. *)\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\n candidate_commitment_added\n 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 return\n ( ctxt,\n (candidate_commitment, candidate_commitment_hash),\n dangling_commitments )\n | None -> tzfail Sc_rollup_no_valid_commitment_to_cement\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 =\n let open Lwt_result_syntax in\n let* old_lcc, old_lcc_level, ctxt =\n Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup\n in\n let* last_proto_activation_level, last_commitment_period =\n Sc_rollup_storage.previous_protocol_constants ctxt\n in\n let new_lcc_previous_protocol =\n Raw_level_repr.add old_lcc_level last_commitment_period\n in\n let new_lcc_level =\n if Raw_level_repr.(new_lcc_previous_protocol < last_proto_activation_level)\n then new_lcc_previous_protocol\n else\n let sc_rollup_commitment_period =\n Constants_storage.sc_rollup_commitment_period_in_blocks ctxt\n in\n Raw_level_repr.add old_lcc_level sc_rollup_commitment_period\n in\n (* Assert conditions to cement are met. *)\n let* ctxt, (new_lcc_commitment, new_lcc_commitment_hash), dangling_commitments\n =\n find_commitment_to_cement ctxt rollup ~old_lcc new_lcc_level\n in\n (* Update the LCC. *)\n let* ctxt, _size_diff =\n Store.Last_cemented_commitment.update ctxt rollup new_lcc_commitment_hash\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_commitment_hash\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, new_lcc_commitment_hash)\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 = "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 [attestation_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 attestation_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 + attestation_lag], the slot may be\n [attested]. For any slot attested by the protocol (i.e. indices returned by\n [finalize_pending_slots]), subscribers of the DAL should take into account\n the corresponding slots.\n\n - For every level below [current_level - attestation_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 ~number_of_slots] finalizes pending slot\n headers which are old enough (i.e. registered at level [current_level -\n attestation_lag]). All slots marked as available are returned. All the\n pending slots at [current_level - attestation_lag] level are removed from\n the context. *)\nval finalize_pending_slot_headers :\n Raw_context.t ->\n number_of_slots:int ->\n (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\n(** [compute_attested_slot_headers ~is_slot_attested published_slot_headers]\n filter the given [published_slot_headers] and return the list of attested\n slot headers and the corresponding bitset. *)\nval compute_attested_slot_headers :\n is_slot_attested:(Dal_slot_repr.Header.t -> bool) ->\n Dal_slot_repr.Header.t list ->\n Dal_slot_repr.Header.t list * Dal_attestation_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\nlet find_slot_headers ctxt level = Storage.Dal.Slot.Headers.find ctxt level\n\nlet finalize_current_slot_headers ctxt =\n Storage.Dal.Slot.Headers.add\n ctxt\n (Raw_context.current_level ctxt).level\n (Raw_context.Dal.candidates ctxt)\n\nlet compute_attested_slot_headers ~is_slot_attested seen_slot_headers =\n let open Dal_slot_repr in\n let fold_attested_slots (rev_attested_slot_headers, attestation) slot =\n if is_slot_attested slot then\n ( slot :: rev_attested_slot_headers,\n Dal_attestation_repr.commit attestation slot.Header.id.index )\n else (rev_attested_slot_headers, attestation)\n in\n let rev_attested_slot_headers, bitset =\n List.fold_left\n fold_attested_slots\n ([], Dal_attestation_repr.empty)\n seen_slot_headers\n in\n (List.rev rev_attested_slot_headers, bitset)\n\nlet get_slot_headers_history ctxt =\n let open Lwt_result_syntax in\n let+ slots_history = Storage.Dal.Slot.History.find ctxt in\n match slots_history with\n | None -> Dal_slot_repr.History.genesis\n | Some slots_history -> slots_history\n\nlet update_skip_list ctxt ~confirmed_slot_headers ~level_attested\n ~number_of_slots =\n let open Lwt_result_syntax in\n let* slots_history = get_slot_headers_history ctxt in\n let*? slots_history =\n Dal_slot_repr.History.add_confirmed_slot_headers_no_cache\n ~number_of_slots\n slots_history\n level_attested\n confirmed_slot_headers\n in\n let*! ctxt = Storage.Dal.Slot.History.add ctxt slots_history in\n return ctxt\n\nlet finalize_pending_slot_headers ctxt ~number_of_slots =\n let open Lwt_result_syntax in\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 let* seen_slots = find_slot_headers ctxt level_attested in\n let*! ctxt = Storage.Dal.Slot.Headers.remove ctxt level_attested in\n let* ctxt, attestation, confirmed_slot_headers =\n match seen_slots with\n | None -> return (ctxt, Dal_attestation_repr.empty, [])\n | Some seen_slots ->\n let attested_slot_headers, attestation =\n let is_slot_attested slot =\n Raw_context.Dal.is_slot_index_attested\n ctxt\n slot.Dal_slot_repr.Header.id.index\n in\n compute_attested_slot_headers ~is_slot_attested seen_slots\n in\n return (ctxt, attestation, attested_slot_headers)\n in\n let* ctxt =\n update_skip_list\n ctxt\n ~confirmed_slot_headers\n ~level_attested\n ~number_of_slots\n in\n return (ctxt, attestation)\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(** [get_game ctxt rollup stakers] returns the [game] between\n [stakers.alice] and [stakers.bob]. *)\nval find_game :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_game_repr.Index.t ->\n (Raw_context.t * Sc_rollup_game_repr.t option) tzresult 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(** Removes pending refutation games in the context where the players\n are no longer staked. *)\nval migrate_clean_refutation_games :\n Raw_context.t -> Raw_context.t tzresult 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 find_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 -> return (ctxt, None)\n | Some game_hash -> Store.Game_info.find (ctxt, rollup) game_hash\n\nlet get_game ctxt rollup stakers =\n let open Lwt_result_syntax in\n let* ctxt, game = find_game ctxt rollup stakers in\n match game with\n | None -> tzfail Sc_rollup_no_game\n | Some game -> return (game, ctxt)\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 constants = Constants_storage.parametric ctxt in\n let dal = constants.dal in\n let dal_activation_level =\n if dal.feature_enable then\n Some constants.sc_rollup.reveal_activation_level.dal_parameters\n else None\n in\n let dal_attested_slots_validity_lag =\n constants.sc_rollup.reveal_activation_level.dal_attested_slots_validity_lag\n 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_activation_level\n ~dal_attestation_lag:dal.attestation_lag\n ~dal_number_of_slots:dal.number_of_slots\n ~stakers\n metadata\n game\n ~step\n ~choice\n ~is_reveal_enabled:\n (Sc_rollup_PVM_sig.is_reveal_enabled_predicate\n (Constants_storage.sc_rollup_reveal_activation_level ctxt))\n ~dal_attested_slots_validity_lag\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 = remove_game ctxt rollup stakers in\n let* ctxt, balances_updates_alice =\n remove_if_staker_is_still_there ctxt rollup stakers.alice\n in\n let* ctxt, balances_updates_bob =\n remove_if_staker_is_still_there 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\nlet migrate_clean_refutation_games ctxt =\n let open Lwt_result_syntax in\n let remove_unstaked_games rollup =\n List.fold_left_es\n (fun ctxt (Sc_rollup_game_repr.Index.{alice; bob} as stakers) ->\n let* ctxt, alice_active =\n Sc_rollup_staker_index_storage.is_staker ctxt rollup alice\n in\n let* ctxt, bob_active =\n Sc_rollup_staker_index_storage.is_staker ctxt rollup bob\n in\n if (not alice_active) && not bob_active then\n remove_game ctxt rollup stakers\n else return ctxt)\n in\n let* rollups = Sc_rollup_storage.list_unaccounted ctxt in\n List.fold_left_es\n (fun ctxt rollup ->\n let*! players =\n Storage.Sc_rollup.Game_info.keys_unaccounted (ctxt, rollup)\n in\n remove_unstaked_games rollup ctxt players)\n ctxt\n rollups\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 = "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_smart_contract:\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 typecheck_smart_rollup:\n (Raw_context.t -> Script_repr.expr -> Raw_context.t tzresult) ->\n ?no_reward_cycles:int ->\n Parameters_repr.bootstrap_account list ->\n Parameters_repr.bootstrap_contract list ->\n Parameters_repr.bootstrap_smart_rollup 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 open Lwt_result_syntax in\n let contract = Contract_repr.Implicit public_key_hash in\n let* ctxt, new_balance_updates =\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n `Bootstrap\n (`Contract contract)\n amount\n in\n let+ ctxt, freeze_balance_updates =\n match public_key with\n | Some public_key -> (\n let* ctxt =\n Contract_manager_storage.reveal_manager_key\n ctxt\n public_key_hash\n public_key\n in\n let* ctxt =\n Delegate_storage.Contract.set\n ctxt\n contract\n (Some (Option.value ~default:public_key_hash delegate_to))\n in\n let* 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 in\n match delegate_to with\n | Some delegate\n when Signature.Public_key_hash.(delegate <> public_key_hash) ->\n return (ctxt, [])\n | _ ->\n (* Self-delegated => contract is a delegate.\n Freeze the largest amount of tokens to avoid over-delegation\n according to the [limit_of_delegation_over_baking].\n This is necessary so that the network (in tests too) starts with\n accounts with baking rights. *)\n let limit_of_delegation_over_baking =\n Constants_storage.limit_of_delegation_over_baking ctxt\n in\n let amount_to_freeze =\n let minimal_to_bake =\n let minimal_stake = Constants_storage.minimal_stake ctxt in\n let minimal_frozen_stake =\n Constants_storage.minimal_frozen_stake ctxt\n in\n Tez_repr.max minimal_stake minimal_frozen_stake\n in\n let minimal_to_not_be_overdelegated =\n Tez_repr.div_exn amount (limit_of_delegation_over_baking + 1)\n in\n Tez_repr.(\n min amount (max minimal_to_bake minimal_to_not_be_overdelegated))\n in\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n (`Contract contract)\n (`Frozen_deposits (Frozen_staker_repr.baker public_key_hash))\n amount_to_freeze)\n | None ->\n let* () =\n fail_when\n (Option.is_some delegate_to)\n (Unrevealed_public_key public_key_hash)\n in\n return (ctxt, [])\n in\n (ctxt, freeze_balance_updates @ new_balance_updates @ balance_updates)\n\nlet init_contract ~typecheck_smart_contract (ctxt, balance_updates)\n ({delegate; amount; script; hash} : Parameters_repr.bootstrap_contract) =\n let open Lwt_result_syntax in\n let*? ctxt, contract_hash =\n match hash with\n | None -> Contract_storage.fresh_contract_from_current_nonce ctxt\n | Some hash -> Result.return (ctxt, hash)\n in\n let* script, ctxt = typecheck_smart_contract ctxt script in\n let* ctxt =\n Contract_storage.raw_originate\n ctxt\n ~prepaid_bootstrap_storage:true\n contract_hash\n ~script\n in\n let contract = Contract_repr.Originated contract_hash in\n let* ctxt =\n match delegate with\n | None -> return ctxt\n | Some delegate -> Delegate_storage.Contract.init ctxt contract delegate\n in\n let origin = Receipt_repr.Protocol_migration in\n let+ ctxt, new_balance_updates =\n Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount\n in\n (ctxt, new_balance_updates @ balance_updates)\n\nlet init_smart_rollup ~typecheck_smart_rollup ctxt\n ({address; boot_sector; pvm_kind; parameters_ty; whitelist} :\n Parameters_repr.bootstrap_smart_rollup) =\n let open Lwt_result_syntax in\n let*? ctxt =\n let open Result_syntax in\n let* parameters_ty = Script_repr.force_decode parameters_ty in\n typecheck_smart_rollup ctxt parameters_ty\n in\n let*! genesis_hash = Sc_rollups.genesis_state_hash_of pvm_kind ~boot_sector in\n let genesis_commitment : Sc_rollup_commitment_repr.t =\n {\n compressed_state = genesis_hash;\n (* Level 0: Genesis block.\n Level 1: Block on protocol genesis, that only activates protocols.\n Level 2: First block on the activated protocol.\n\n Therefore we originate the rollup at level 2 so the rollup node\n doesn't ask a block on a different protocol.\n *)\n inbox_level = Raw_level_repr.of_int32_exn 2l;\n predecessor = Sc_rollup_commitment_repr.Hash.zero;\n number_of_ticks = Sc_rollup_repr.Number_of_ticks.zero;\n }\n in\n let* _, _, ctxt =\n Sc_rollup_storage.raw_originate\n ctxt\n ~kind:pvm_kind\n ~genesis_commitment\n ~parameters_ty\n ~address\n ?whitelist\n in\n return ctxt\n\nlet init ctxt ~typecheck_smart_contract ~typecheck_smart_rollup\n ?no_reward_cycles accounts contracts smart_rollups =\n let open Lwt_result_syntax in\n let nonce = Operation_hash.hash_string [\"Un festival de GADT.\"] in\n let ctxt = Raw_context.init_origination_nonce ctxt nonce in\n let* ctxt, balance_updates =\n List.fold_left_es init_account (ctxt, []) accounts\n in\n let* ctxt, balance_updates =\n List.fold_left_es\n (init_contract ~typecheck_smart_contract)\n (ctxt, balance_updates)\n contracts\n in\n let* ctxt =\n List.fold_left_es\n (init_smart_rollup ~typecheck_smart_rollup)\n ctxt\n smart_rollups\n in\n let+ ctxt =\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 let*! ctxt =\n Raw_context.patch_constants ctxt (fun c ->\n {\n c with\n issuance_weights =\n {\n c.issuance_weights with\n base_total_issued_per_minute = Tez_repr.zero;\n };\n })\n in\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 (* Hack: we store the rewards here *)\n baking_reward_fixed_portion =\n constants.issuance_weights.base_total_issued_per_minute;\n baking_reward_bonus_per_slot = Tez_repr.zero;\n attesting_reward_per_slot = Tez_repr.zero;\n })\n in\n (ctxt, balance_updates)\n\nlet cycle_end ctxt last_cycle =\n let open Lwt_result_syntax in\n let next_cycle = Cycle_repr.succ last_cycle in\n let* result = Storage.Ramp_up.Rewards.find ctxt next_cycle in\n match result with\n | None -> return ctxt\n | Some Storage.Ramp_up.{baking_reward_fixed_portion; _} ->\n let* ctxt = Storage.Ramp_up.Rewards.remove_existing ctxt next_cycle in\n let*! ctxt =\n Raw_context.patch_constants ctxt (fun c ->\n {\n c with\n issuance_weights =\n {\n c.issuance_weights with\n base_total_issued_per_minute = baking_reward_fixed_portion;\n };\n })\n in\n return ctxt\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_smart_contract:\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 typecheck_smart_rollup:\n (Raw_context.t -> Script_repr.expr -> Raw_context.t tzresult) ->\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 let open Lwt_result_syntax in\n match Tez_repr.of_mutez amount_mutez with\n | None -> Lwt.return (ctxt, [])\n | Some amount -> (\n let*! result =\n let*? recipient = Contract_repr.of_b58check address in\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n `Invoice\n (`Contract recipient)\n amount\n in\n Lwt.return @@ match result with Ok res -> res | 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 ctxt (address, hash, patched_code) =\n let open Lwt_result_syntax in\n let*? contract = Contract_repr.of_b58check address in\n let* ctxt, code_opt = Storage.Contract.Code.find ctxt contract in\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 let* ctxt, size_diff =\n Storage.Contract.Code.update ctxt contract new_code\n in\n Logging.log Notice \"Contract %s successfully patched\" address ;\n let size_diff = Z.of_int size_diff in\n let* prev_size =\n Storage.Contract.Used_storage_space.get ctxt contract\n in\n let new_size = Z.add prev_size size_diff in\n let* ctxt =\n Storage.Contract.Used_storage_space.update ctxt contract new_size\n in\n if Z.(gt size_diff zero) then\n let* prev_paid_size =\n Storage.Contract.Paid_storage_space.get ctxt contract\n in\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_smart_contract\n ~typecheck_smart_rollup ~level ~timestamp ~predecessor =\n let open Lwt_result_syntax in\n let* previous_protocol, _previous_proto_constants, ctxt =\n Raw_context.prepare_first_block ~level ~timestamp chain_id ctxt\n in\n let parametric = Raw_context.constants ctxt in\n let*! ctxt =\n let*! ctxt =\n Raw_context.Cache.set_cache_layout\n ctxt\n (Constants_repr.cache_layout parametric)\n in\n Lwt.return (Raw_context.Cache.clear ctxt)\n in\n let* ctxt, balance_updates =\n match previous_protocol with\n | Genesis param ->\n (* This is the genesis protocol: initialise the state *)\n let*? level = Raw_level_repr.of_int32 level in\n let* ctxt =\n Storage.Tenderbake.First_level_of_protocol.init ctxt level\n in\n let* ctxt = Forbidden_delegates_storage.init_for_genesis ctxt in\n let*! ctxt = Storage.Contract.Total_supply.add ctxt Tez_repr.zero in\n let* ctxt = Storage.Block_round.init ctxt Round_repr.zero in\n let init_commitment (ctxt, balance_updates)\n Commitment_repr.{blinded_public_key_hash; amount} =\n let* ctxt, new_balance_updates =\n Token.transfer\n ctxt\n `Initial_commitments\n (`Collected_commitments blinded_public_key_hash)\n amount\n in\n return (ctxt, new_balance_updates @ balance_updates)\n in\n let* ctxt, commitments_balance_updates =\n List.fold_left_es init_commitment (ctxt, []) param.commitments\n in\n let* ctxt =\n Seed_storage.init ?initial_seed:param.constants.initial_seed ctxt\n in\n let* ctxt = Contract_storage.init ctxt in\n let* ctxt, bootstrap_balance_updates =\n Bootstrap_storage.init\n ctxt\n ~typecheck_smart_contract\n ~typecheck_smart_rollup\n ?no_reward_cycles:param.no_reward_cycles\n param.bootstrap_accounts\n param.bootstrap_contracts\n param.bootstrap_smart_rollups\n in\n let* ctxt = Delegate_cycles.init_first_cycles ctxt in\n let* ctxt =\n Vote_storage.init\n ctxt\n ~start_position:(Level_storage.current ctxt).level_position\n in\n let* ctxt = Vote_storage.update_listings ctxt in\n (* Must be called after other originations since it unsets the origination nonce. *)\n let* ctxt, operation_results =\n Liquidity_baking_migration.init\n ctxt\n ~typecheck:typecheck_smart_contract\n in\n let* ctxt =\n Storage.Pending_migration.Operation_results.init\n ctxt\n operation_results\n in\n let* ctxt = Sc_rollup_inbox_storage.init_inbox ~predecessor ctxt in\n let* ctxt = Adaptive_issuance_storage.init ctxt in\n\n (* TODO: Remove this for Q, and fallback to use the previous constants\n and [Tenderbake.First_level_of_protocol] *)\n let*! ctxt =\n Storage.Sc_rollup.Parisb2_activation_level.add\n ctxt\n Raw_level_repr.root\n in\n let*! ctxt = Sc_rollup_storage.set_previous_commitment_period ctxt 1 in\n\n return (ctxt, commitments_balance_updates @ bootstrap_balance_updates)\n | ParisB_019 ->\n let*? level = Raw_level_repr.of_int32 level in\n let* ctxt =\n Storage.Tenderbake.First_level_of_protocol.update ctxt level\n in\n (* Migration of refutation games needs to be kept for each protocol. *)\n let* ctxt =\n Sc_rollup_refutation_storage.migrate_clean_refutation_games ctxt\n in\n\n (* TODO: Remove this for Q, and fallback to use the previous constants\n and [Tenderbake.First_level_of_protocol].\n\n We need to hard-code Oxford2 values, because they are the one of\n interest, not ParisB2\226\128\153s. *)\n let parisb2_activation_level, previous_commitment_period =\n if Chain_id.(chain_id = Constants_repr.mainnet_id) then\n (Raw_level_repr.of_int32_exn 5726209l, 60)\n else if Chain_id.(chain_id = Constants_repr.ghostnet_id) then\n (Raw_level_repr.of_int32_exn 6422529l, 60)\n else\n (* Setting [paris2b_activation_level = Raw_level_repr.root] ensures\n that we will never consider an uncemented commitment as posted\n during the previous protocol. *)\n (Raw_level_repr.root, 1)\n in\n (* Remember the previous commitment period value, in order to deal with\n commitments posted during previous protocol but not yet cemented\n when this protocol was activated. *)\n let*! ctxt =\n Sc_rollup_storage.set_previous_commitment_period\n ctxt\n previous_commitment_period\n in\n let*! ctxt =\n Storage.Sc_rollup.Parisb2_activation_level.add\n ctxt\n parisb2_activation_level\n in\n\n return (ctxt, [])\n in\n let* ctxt =\n List.fold_left_es patch_script ctxt Legacy_script_patches.addresses_to_patch\n in\n let*? balance_updates = Receipt_repr.group_balance_updates balance_updates in\n let*! ctxt =\n Storage.Pending_migration.Balance_updates.add ctxt balance_updates\n in\n if Constants_storage.adaptive_issuance_force_activation ctxt then\n let ctxt = Raw_context.set_adaptive_issuance_enable ctxt in\n let* ctxt =\n let current_cycle = (Level_storage.current ctxt).cycle in\n Storage.Adaptive_issuance.Activation.update ctxt (Some current_cycle)\n in\n return ctxt\n else return ctxt\n\nlet prepare ctxt ~level ~predecessor_timestamp ~timestamp =\n let open Lwt_result_syntax in\n let* ctxt =\n Raw_context.prepare\n ~level\n ~predecessor_timestamp\n ~timestamp\n ~adaptive_issuance_enable:false\n ctxt\n in\n let* ctxt = Adaptive_issuance_storage.set_adaptive_issuance_enable ctxt in\n Storage.Pending_migration.remove ctxt\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 | 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(* Copyright (c) 2024 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\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 to_int : t -> int\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 val zero : t\n\n val one_mutez : t\n\n val one_cent : t\n\n val fifty_cents : t\n\n val one : t\n\n val max_mutez : t\n\n val ( -? ) : t -> t -> t tzresult\n\n val sub_opt : t -> t -> t option\n\n val ( +? ) : t -> t -> t tzresult\n\n val ( *? ) : t -> int64 -> t tzresult\n\n val ( /? ) : t -> int64 -> t tzresult\n\n val of_string : string -> t option\n\n val to_string : t -> string\n\n val of_mutez : int64 -> t option\n\n val to_mutez : t -> 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 {!Staking_pseudotoken_repr}. *)\nmodule Staking_pseudotoken : sig\n type t\n\n module For_RPC : sig\n val encoding : t Data_encoding.encoding\n end\n\n module Internal_for_tests : sig\n val to_z : t -> Z.t\n end\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\n val from_repr : Raw_level_repr.t -> raw_level\n\n val to_repr : raw_level -> Raw_level_repr.t\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 val ( ---> ) : cycle -> cycle -> cycle list\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\n\n module Internal_for_tests : sig\n val from_repr : Round_repr.t -> t\n\n val to_repr : t -> Round_repr.t\n end\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_Ticket\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 is_unit : expr -> bool\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 max_slashing_period : 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 incentives_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n attestation_threshold : int;\n cryptobox_parameters : Dal.parameters;\n }\n\n val dal_encoding : dal Data_encoding.t\n\n type sc_rollup_reveal_hashing_schemes = {blake2B : Raw_level.t}\n\n type sc_rollup_reveal_activation_level = {\n raw_data : sc_rollup_reveal_hashing_schemes;\n metadata : Raw_level.t;\n dal_page : Raw_level.t;\n dal_parameters : Raw_level.t;\n dal_attested_slots_validity_lag : int;\n }\n\n type sc_rollup = {\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 reveal_activation_level : sc_rollup_reveal_activation_level;\n private_enable : bool;\n riscv_pvm_enable : bool;\n }\n\n type zk_rollup = {\n enable : bool;\n origination_size : int;\n min_pending_to_process : int;\n max_ticket_payload_size : int;\n }\n\n type adaptive_rewards_params = {\n issuance_ratio_final_min : Q.t;\n issuance_ratio_final_max : Q.t;\n issuance_ratio_initial_min : Q.t;\n issuance_ratio_initial_max : Q.t;\n initial_period : int;\n transition_period : int;\n max_bonus : Issuance_bonus_repr.max_bonus;\n growth_rate : Q.t;\n center_dz : Q.t;\n radius_dz : Q.t;\n }\n\n type adaptive_issuance = {\n global_limit_of_staking_over_baking : int;\n edge_of_staking_over_delegation : int;\n launch_ema_threshold : int32;\n adaptive_rewards_params : adaptive_rewards_params;\n activation_vote_enable : bool;\n autostaking_enable : bool;\n force_activation : bool;\n ns_enable : bool;\n }\n\n type issuance_weights = {\n base_total_issued_per_minute : Tez.t;\n baking_reward_fixed_portion_weight : int;\n baking_reward_bonus_weight : int;\n attesting_reward_weight : int;\n seed_nonce_revelation_tip_weight : int;\n vdf_revelation_tip_weight : int;\n }\n\n type t = {\n consensus_rights_delay : int;\n blocks_preservation_cycles : int;\n delegate_parameters_activation_delay : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : 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 minimal_frozen_stake : Tez.t;\n vdf_difficulty : int64;\n origination_size : int;\n issuance_weights : issuance_weights;\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 limit_of_delegation_over_baking : int;\n percentage_of_frozen_deposits_slashed_per_double_baking : Percentage.t;\n percentage_of_frozen_deposits_slashed_per_double_attestation :\n Percentage.t;\n max_slashing_per_block : Percentage.t;\n max_slashing_threshold : int;\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 dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n adaptive_issuance : adaptive_issuance;\n direct_ticket_spending_enable : bool;\n }\n\n val encoding : t Data_encoding.t\n\n val update_sc_rollup_parameter : block_time:int -> sc_rollup -> sc_rollup\n\n module Internal_for_tests : sig\n val sc_rollup_encoding : sc_rollup Data_encoding.t\n end\n end\n\n module Generated : sig\n type t = {\n consensus_threshold : int;\n issuance_weights : Parametric.issuance_weights;\n max_slashing_threshold : int;\n }\n\n val generate : consensus_committee_size:int -> t\n end\n\n val parametric : context -> Parametric.t\n\n val sc_rollup : context -> Parametric.sc_rollup\n\n val consensus_rights_delay : context -> int\n\n val blocks_preservation_cycles : context -> int\n\n val delegate_parameters_activation_delay : context -> int\n\n val slashable_deposits_period : context -> int\n\n val issuance_modification_delay : 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 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 minimal_frozen_stake : context -> Tez.t\n\n val vdf_difficulty : context -> int64\n\n val origination_size : context -> int\n\n val issuance_weights : context -> Parametric.issuance_weights\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_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 limit_of_delegation_over_baking : context -> int\n\n val percentage_of_frozen_deposits_slashed_per_double_baking :\n context -> Percentage.t\n\n val percentage_of_frozen_deposits_slashed_per_double_attestation :\n context -> Percentage.t\n\n val testnet_dictator : context -> public_key_hash option\n\n val sc_rollup_arith_pvm_enable : context -> bool\n\n val sc_rollup_riscv_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 sc_rollup_reveal_activation_level :\n context -> Parametric.sc_rollup_reveal_activation_level\n\n val sc_rollup_private_enable : context -> bool\n\n val zk_rollup_enable : context -> bool\n\n val zk_rollup_min_pending_to_process : context -> int\n\n val adaptive_issuance_enable : context -> bool\n\n val zk_rollup_max_ticket_payload_size : context -> int\n\n val direct_ticket_spending_enable : context -> bool\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_preserved_block_level : context -> Raw_level.t\n\n val dawn_of_a_new_cycle : context -> Cycle.t option\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 (** See {!Fitness_repr.locked_round_from_raw}. *)\n val locked_round_from_raw : raw -> Round.t option 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 (** See {!Contract_delegate_storage.is_delegate}. *)\n val is_delegate : context -> public_key_hash -> bool tzresult Lwt.t\n\n (** See {!Contract_delegate_storage.delegate_status}. *)\n type delegate_status =\n | Delegate\n | Delegated of Signature.Public_key_hash.t\n | Undelegated\n\n (** See {!Contract_delegate_storage.get_delegate_status}. *)\n val get_delegate_status :\n context -> public_key_hash -> delegate_status tzresult Lwt.t\n\n val get_total_supply : context -> Tez.t 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\n\n (** Functions used exclusively for RPC calls *)\n module For_RPC : sig\n val get_staked_balance : context -> t -> Tez.t option tzresult Lwt.t\n\n val get_unstaked_frozen_balance :\n context -> t -> Tez.t option tzresult Lwt.t\n\n val get_unstaked_finalizable_balance :\n context -> t -> Tez.t option tzresult Lwt.t\n\n val get_full_balance : context -> t -> Tez.t tzresult Lwt.t\n\n (** [get_estimated_own_pending_slashed_amount ctxt contract]\n returns the estimated own pending slashed amount of the given [contract]\n according to the currently available denunciations. *)\n val get_estimated_own_pending_slashed_amount :\n context -> t -> Tez.t tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Bond_id_repr}. *)\nmodule Bond_id : sig\n type t = Sc_rollup_bond_id of Smart_rollup.Address.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} and {!Staker_repr}. *)\nmodule Receipt : sig\n module Token : sig\n type 'token t =\n | Tez : Tez.t t\n | Staking_pseudotoken : Staking_pseudotoken.t t\n\n val eq :\n 'token1 t -> 'token2 t -> ('token1, 'token2) Equality_witness.eq option\n\n val add : 'token t -> 'token -> 'token -> 'token tzresult\n\n val pp : 'token t -> Format.formatter -> 'token -> unit\n end\n\n type unstaked_frozen_staker =\n | Single of Contract.t * Signature.public_key_hash\n | Shared of Signature.public_key_hash\n\n type frozen_staker = private\n | Baker of Signature.public_key_hash\n | Single_staker of {\n staker : Contract.t;\n delegate : Signature.public_key_hash;\n }\n | Shared_between_stakers of {delegate : Signature.public_key_hash}\n | Baker_edge of Signature.public_key_hash\n\n val frozen_baker : Signature.public_key_hash -> frozen_staker\n\n val frozen_baker_edge : Signature.public_key_hash -> frozen_staker\n\n val frozen_single_staker :\n staker:Contract.t -> delegate:Signature.public_key_hash -> frozen_staker\n\n val frozen_shared_between_stakers :\n delegate:Signature.public_key_hash -> frozen_staker\n\n type 'token balance =\n | Contract : Contract.t -> Tez.t balance\n | Block_fees : Tez.t balance\n | Deposits : frozen_staker -> Tez.t balance\n | Unstaked_deposits : unstaked_frozen_staker * Cycle.t -> Tez.t balance\n | Nonce_revelation_rewards : Tez.t balance\n | Attesting_rewards : Tez.t balance\n | Baking_rewards : Tez.t balance\n | Baking_bonuses : Tez.t balance\n | Storage_fees : Tez.t balance\n | Double_signing_punishments : Tez.t balance\n | Lost_attesting_rewards : public_key_hash * bool * bool -> Tez.t balance\n | Liquidity_baking_subsidies : Tez.t balance\n | Burned : Tez.t balance\n | Commitments : Blinded_public_key_hash.t -> Tez.t balance\n | Bootstrap : Tez.t balance\n | Invoice : Tez.t balance\n | Initial_commitments : Tez.t balance\n | Minted : Tez.t balance\n | Frozen_bonds : Contract.t * Bond_id.t -> Tez.t balance\n | Sc_rollup_refutation_punishments : Tez.t balance\n | Sc_rollup_refutation_rewards : Tez.t balance\n | Staking_delegator_numerator : {\n delegator : Contract.t;\n }\n -> Staking_pseudotoken.t balance\n | Staking_delegate_denominator : {\n delegate : public_key_hash;\n }\n -> Staking_pseudotoken.t balance\n\n val token_of_balance : 'token balance -> 'token Token.t\n\n type 'token balance_update = Debited of 'token | Credited of 'token\n\n type update_origin =\n | Block_application\n | Protocol_migration\n | Subsidy\n | Simulation\n | Delayed_operation of {operation_hash : Operation_hash.t}\n\n type balance_update_item = private\n | Balance_update_item :\n 'token balance * 'token balance_update * update_origin\n -> balance_update_item\n\n val item :\n 'token balance ->\n 'token balance_update ->\n update_origin ->\n balance_update_item\n\n type balance_updates = balance_update_item list\n\n val balance_updates_encoding : balance_updates Data_encoding.t\n\n val balance_updates_encoding_with_legacy_attestation_name :\n balance_updates Data_encoding.t\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 {!Misbehaviour_repr}. *)\nmodule Misbehaviour : sig\n type kind = Double_baking | Double_attesting | Double_preattesting\n\n type t = {level : Raw_level.t; round : Round.t; kind : kind}\n\n val kind_encoding : kind Data_encoding.t\n\n val compare_kind : kind -> kind -> int\nend\n\n(** This module re-exports definitions from {!Delegate_storage},\n {!Delegate_consensus_key}, {!Delegate_missed_attestations_storage},\n {!Delegate_slashed_deposits_storage}, {!Delegate_cycles},\n {!Delegate_rewards}, and {!Forbidden_delegates_storage}. *)\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 val cycle_end :\n context ->\n Cycle.t ->\n (context * Receipt.balance_updates * public_key_hash list) tzresult Lwt.t\n\n (** See {!Already_denounced_storage.already_denounced}. *)\n val already_denounced :\n context ->\n public_key_hash ->\n Level.t ->\n Round.t ->\n Misbehaviour.kind ->\n bool tzresult Lwt.t\n\n type reward_and_burn = {reward : Tez.t; amount_to_burn : Tez.t}\n\n type punishing_amounts = {\n staked : reward_and_burn;\n unstaked : (Cycle.t * reward_and_burn) list;\n }\n\n (** See {!Delegate_slashed_deposits_storage.punish_double_signing}. *)\n val punish_double_signing :\n context ->\n operation_hash:Operation_hash.t ->\n Misbehaviour.t ->\n public_key_hash ->\n Level.t ->\n rewarded:public_key_hash ->\n context 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_attesting_participation :\n context ->\n delegate:public_key_hash ->\n participation:level_participation ->\n attesting_power:int ->\n context tzresult Lwt.t\n\n val current_frozen_deposits :\n context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n val initial_frozen_deposits :\n 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 registered : context -> public_key_hash -> bool Lwt.t\n\n val deactivated : context -> public_key_hash -> bool tzresult Lwt.t\n\n (** See {!Forbidden_delegates_storage.is_forbidden}. *)\n val is_forbidden_delegate : t -> public_key_hash -> bool\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 * public_key) 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\n\n module Rewards : sig\n val baking_reward_fixed_portion : t -> Tez.t tzresult\n\n val baking_reward_bonus_per_slot : t -> Tez.t tzresult\n\n val attesting_reward_per_slot : t -> Tez.t tzresult\n\n val liquidity_baking_subsidy : t -> Tez.t tzresult\n\n val seed_nonce_revelation_tip : t -> Tez.t tzresult\n\n val vdf_revelation_tip : t -> Tez.t tzresult\n\n module For_RPC : sig\n type reward_kind =\n | Baking_reward_fixed_portion\n | Baking_reward_bonus_per_slot\n | Attesting_reward_per_slot\n | Seed_nonce_revelation_tip\n | Vdf_revelation_tip\n\n (** [reward_from_constants ~coeff csts ~reward_kind] returns the amount of\n rewards in {!Tez.t} for the given [reward_kind], according to the\n given parameters in [csts]. The (optional) value [coeff] is a\n multiplicative factor applied to the rewards (default = 1).\n It verifies [reward_from_constants ~coeff csts ~reward_kind =\n coeff * reward_from_constants csts ~reward_kind]. *)\n val reward_from_constants :\n ?coeff:Q.t ->\n Constants.Parametric.t ->\n reward_kind:reward_kind ->\n Tez.t tzresult\n\n val liquidity_baking_subsidy_from_constants :\n Constants.Parametric.t -> Tez.t tzresult\n\n (** [get_reward_coeff ctxt cycle] reads the reward coeff for the given cycle\n from the storage.\n Returns [Q.one] if the given cycle is not between [current_cycle] and\n [current_cycle + consensus_rights_delay].\n If adaptive issuance has not been activated, or has been activated and the\n given cycle is less than [consensus_rights_delay] after the activation cycle,\n then this function returns [Q.one].\n Used only for RPCs. To get the actual rewards, use the reward functions\n defined above. *)\n val get_reward_coeff : t -> cycle:Cycle.t -> Q.t tzresult Lwt.t\n\n (** [get_reward_bonus ctxt cycle] reads the reward bonus for the given cycle\n from the storage. If cycle is [None], returns 0.\n\n Returns 0 if the given cycle is not between [current_cycle] and\n [current_cycle + consensus_rights_delay].\n\n If adaptive issuance has not been activated,\n then this function returns 0.\n Used only for RPCs. To get the actual rewards, use [Delegate_rewards]. *)\n val get_reward_bonus :\n t -> cycle:Cycle.t option -> Issuance_bonus_repr.t tzresult Lwt.t\n end\n\n module Internal_for_tests : sig\n (** Reward computation functions *)\n val compute_reward_coeff_ratio_without_bonus :\n stake_ratio:Q.t ->\n issuance_ratio_max:Q.t ->\n issuance_ratio_min:Q.t ->\n Q.t\n\n val compute_bonus :\n issuance_ratio_max:Q.t ->\n seconds_per_cycle:int64 ->\n stake_ratio:Q.t ->\n base_reward_coeff_ratio:Q.t ->\n previous_bonus:Issuance_bonus_repr.t ->\n reward_params:Constants.Parametric.adaptive_rewards_params ->\n Issuance_bonus_repr.t tzresult\n\n val compute_coeff :\n issuance_ratio_max:Q.t ->\n issuance_ratio_min:Q.t ->\n base_total_issued_per_minute:Tez_repr.t ->\n base_reward_coeff_ratio:Q.t ->\n q_total_supply:Q.t ->\n bonus:Issuance_bonus_repr.t ->\n Q.t\n\n val compute_min :\n reward_params:Constants.Parametric.adaptive_rewards_params ->\n launch_cycle:Cycle_repr.t option ->\n new_cycle:Cycle_repr.t ->\n Q.t\n\n val compute_max :\n reward_params:Constants.Parametric.adaptive_rewards_params ->\n launch_cycle:Cycle_repr.t option ->\n new_cycle:Cycle_repr.t ->\n Q.t\n end\n end\n\n module Staking_parameters : sig\n val register_update :\n context ->\n Signature.Public_key_hash.t ->\n Staking_parameters_repr.t ->\n context tzresult Lwt.t\n\n val of_delegate :\n context ->\n Signature.Public_key_hash.t ->\n Staking_parameters_repr.t tzresult Lwt.t\n\n val pending_updates :\n context ->\n Signature.Public_key_hash.t ->\n (Cycle.t * Staking_parameters_repr.t) list tzresult Lwt.t\n end\n\n module Shared_stake : sig\n val pay_rewards :\n context ->\n ?active_stake:Stake_repr.t ->\n source:[< Token.giver] ->\n delegate:public_key_hash ->\n Tez.t ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n end\n\n (** The functions in this module are considered too costly to be used in\n the protocol.\n They are meant to be used only to answer RPC calls. *)\n module For_RPC : sig\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_attesting_rewards : Tez.t;\n }\n\n val participation_info :\n context -> public_key_hash -> participation_info tzresult Lwt.t\n\n (** Returns the full 'balance' of the implicit contract associated to a\n given key, i.e. the sum of the spendable balance (given by [balance] or\n [Contract_storage.get_balance]) and of the frozen balance of the\n contract.\n\n The frozen balance is composed of all frozen bonds associated to the\n contract (given by [Contract_storage.get_frozen_bonds]), all unstaked\n frozen deposits, and of the fraction of the frozen deposits that\n actually belongs to the delegate and not to its stakers.\n\n Only use this function for RPCs: this is expensive. *)\n val full_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n val delegated_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n val staking_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n val min_delegated_in_current_cycle :\n context -> public_key_hash -> (Tez.t * Level_repr.t option) tzresult Lwt.t\n\n val has_pending_denunciations : context -> public_key_hash -> bool Lwt.t\n\n val pending_denunciations :\n context -> public_key_hash -> Denunciations_repr.t tzresult Lwt.t\n\n val pending_denunciations_list :\n context -> (public_key_hash * Denunciations_repr.item) list Lwt.t\n\n (** [get_estimated_shared_pending_slashed_amount ctxt delegate]\n returns the estimated shared pending slashed amount of the given [delegate]\n according to the currently available denunciations. *)\n val get_estimated_shared_pending_slashed_amount :\n context -> public_key_hash -> Tez.t tzresult Lwt.t\n end\nend\n\nmodule Staking : sig\n (** [stake ctxt ~sender ~delegate amount] add [amount] as [sender]'s stake\n to [delegate]. *)\n val stake :\n context ->\n amount:[`At_most of Tez.t | `Exactly of Tez.t] ->\n sender:public_key_hash ->\n delegate:public_key_hash ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n (** [request_unstake ctxt ~sender_contract ~delegate amount] records a request\n from [sender_contract] to unstake [amount] from [delegate]. *)\n val request_unstake :\n context ->\n sender_contract:Contract.t ->\n delegate:public_key_hash ->\n Tez.t ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n (** [finalize_unstake ctxt contract] performs the finalization of all unstake\n requests from [contract] that can be finalized.\n An unstake request can be finalized if it is old enough, specifically the\n requested amount must not be at stake anymore and must not be slashable\n anymore, i.e. after [consensus_rights_delay + max_slashing_period] after the\n request.\n Amounts are transferred from the [contract]'s delegate (at request time)\n unstaked frozen deposits to [contract]'s spendable balance, minus slashing\n the requested stake undergone in between. *)\n val finalize_unstake :\n context -> Contract.t -> (context * Receipt.balance_updates) tzresult Lwt.t\n\n (** Staking can be either automated or manual. If Adaptive Issuance is\n enabled, staking must be manual. *)\n type staking_automation = Auto_staking | Manual_staking\n\n val staking_automation : context -> staking_automation\n\n val check_manual_staking_allowed : context -> unit tzresult\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_current_voting_power_free :\n context -> public_key_hash -> 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 type cryptobox\n\n val make : context -> (context * cryptobox) tzresult\n\n val number_of_slots : context -> int\n\n val number_of_shards : context -> int\n\n (** This module re-exports definitions from {!Dal_slot_index_repr}. *)\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_opt : number_of_slots:int -> int -> t option\n\n val of_int : number_of_slots:int -> int -> t tzresult\n\n val to_int : t -> int\n\n val to_int_list : t list -> int list\n\n val compare : t -> t -> int\n\n val equal : t -> t -> bool\n\n val slots_range :\n number_of_slots:int -> lower:int -> upper:int -> t list tzresult\n\n val slots_range_opt :\n number_of_slots:int -> lower:int -> upper:int -> t list option\n\n val check_is_in_range : number_of_slots:int -> t -> unit tzresult\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 = private Bitset.t\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 commit : t -> Slot_index.t -> 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 record_number_of_attested_shards : context -> t -> int -> 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\n type error += Invalid_page_index of {given : int; min : int; max : int}\n\n val check_is_in_range : number_of_pages:int -> t -> unit tzresult\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 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 end\n\n val register_slot_header : context -> Header.t -> context 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 -> number_of_slots:int -> (context * Attestation.t) tzresult Lwt.t\n\n val compute_attested_slot_headers :\n is_slot_attested:(Header.t -> bool) ->\n Header.t list ->\n Header.t list * Attestation.t\n end\n\n module Operations : sig\n module Publish_commitment : sig\n type t = {\n slot_index : Slot_index.t;\n commitment : Slot.Commitment.t;\n commitment_proof : Slot.Commitment_proof.t;\n }\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val slot_header :\n cryptobox:cryptobox ->\n number_of_slots:int ->\n current_level:Raw_level.t ->\n t ->\n Slot.Header.t tzresult\n end\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 ->\n Raw_level.t ->\n number_of_slots:int ->\n Slot.Header.t list ->\n t tzresult\n\n val add_confirmed_slot_headers :\n t ->\n History_cache.t ->\n Raw_level.t ->\n number_of_slots:int ->\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 : context -> 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 of {given : int; limit : int}\n | Dal_publish_commitment_invalid_index of {\n given : Dal.Slot_index.t;\n maximum : Dal.Slot_index.t;\n }\n | Dal_publish_commitment_candidate_with_low_fees of {proposed_fees : Tez.t}\n | Dal_attestation_size_limit_exceeded of {maximum_size : int; got : int}\n | Dal_publish_commitment_duplicate of {slot_header : Dal.Slot.Header.t}\n | Dal_publish_commitment_invalid_proof of {\n commitment : Dal.Slot.Commitment.t;\n commitment_proof : Dal.Slot.Commitment_proof.t;\n }\n | Dal_data_availibility_attester_not_in_committee of {\n attester : Signature.Public_key_hash.t;\n level : Raw_level.t;\n slot : Slot.t;\n }\n | Dal_cryptobox_error of {explanation : string}\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 : module type of struct\n include Smart_rollup.Address\n end\n\n type t = Smart_rollup.Address.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 Whitelist : sig\n type t = public_key_hash list\n\n val init :\n context ->\n Address.t ->\n whitelist:t ->\n origination_level:Raw_level.t ->\n (context * Z.t) tzresult Lwt.t\n\n val is_private : context -> Address.t -> (context * bool) tzresult Lwt.t\n\n val find_whitelist_uncarbonated :\n context -> Address.t -> t option tzresult Lwt.t\n\n val replace :\n context -> Address.t -> whitelist:t -> (context * Z.t) tzresult Lwt.t\n\n val make_public : context -> Address.t -> (context * Z.t) tzresult Lwt.t\n\n val adjust_storage_space :\n context ->\n Address.t ->\n new_storage_size:Z.t ->\n (context * Z.t) tzresult Lwt.t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n type last_whitelist_update = {\n message_index : Z.t;\n outbox_level : Raw_level.t;\n }\n\n val last_whitelist_update_encoding : last_whitelist_update Data_encoding.t\n\n val get_last_whitelist_update :\n context ->\n Sc_rollup_repr.t ->\n (context * last_whitelist_update) tzresult Lwt.t\n\n val set_last_whitelist_update :\n context ->\n Sc_rollup_repr.t ->\n last_whitelist_update ->\n (context * Z.t) tzresult Lwt.t\n\n type update = Public | Private of t\n\n val update_encoding : update Data_encoding.t\n end\n\n module Staker : sig\n include S.SIGNATURE_PUBLIC_KEY_HASH with type t = public_key_hash\n\n val rpc_arg_staker1 : t RPC_arg.t\n\n val rpc_arg_staker2 : t RPC_arg.t\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 : module type of struct\n include Smart_rollup.State_hash\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_dal_parameters_repr}. *)\n module Dal_parameters : sig\n type t = {\n number_of_slots : int64;\n attestation_lag : int64;\n slot_size : int64;\n page_size : int64;\n }\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 | Protocol_migration of string\n\n val protocol_migration_internal_message : internal_inbox_message\n\n type t = Internal of internal_inbox_message | External of string\n\n type serialized = private string\n\n val protocol_migration_serialized_message : 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 :\n S.HASH with type t = Smart_rollup.Merkelized_payload_hashes_hash.t\n\n type t\n\n val encoding : t Data_encoding.t\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 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_no_history : Inbox_message.serialized -> t\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 pp_proof : Format.formatter -> proof -> unit\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 | Dal_parameters of Dal_parameters.t\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 | Reveal_dal_parameters\n\n type is_reveal_enabled = current_block_level:Raw_level.t -> reveal -> bool\n\n val reveal_encoding : reveal Data_encoding.t\n\n val pp_reveal : Format.formatter -> reveal -> unit\n\n val is_reveal_enabled_predicate :\n Constants.Parametric.sc_rollup_reveal_activation_level -> is_reveal_enabled\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.S\n\n module Hash : S.HASH with type t = Smart_rollup.Inbox_hash.t\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 history_proof_encoding : history_proof Data_encoding.t\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 first_block:bool ->\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 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\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\n\n val genesis :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n Raw_level.t ->\n t\n\n module Internal_for_tests : sig\n type inclusion_proof = history_proof list\n\n val pp_inclusion_proof : Format.formatter -> inclusion_proof -> unit\n\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 verify_inclusion_proof :\n inclusion_proof -> history_proof -> history_proof tzresult\n\n type payloads_proof = {\n proof : Inbox_merkelized_payload_hashes.proof;\n payload : Inbox_message.serialized option;\n }\n\n val pp_payloads_proof : Format.formatter -> payloads_proof -> unit\n\n val produce_payloads_proof :\n (Inbox_merkelized_payload_hashes.Hash.t ->\n Inbox_merkelized_payload_hashes.History.t Lwt.t) ->\n Inbox_merkelized_payload_hashes.Hash.t ->\n index:Z.t ->\n payloads_proof tzresult Lwt.t\n\n val verify_payloads_proof :\n payloads_proof ->\n Inbox_merkelized_payload_hashes.Hash.t ->\n Z.t ->\n Inbox_message.serialized option tzresult\n\n val serialized_proof_of_string : string -> serialized_proof\n\n type level_proof = {\n hash : Inbox_merkelized_payload_hashes.Hash.t;\n level : Raw_level_repr.t;\n }\n\n val level_proof_of_history_proof : history_proof -> level_proof\n\n val expose_proof : proof -> inclusion_proof * payloads_proof\n\n val make_proof : inclusion_proof -> payloads_proof -> proof\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 tzresult Lwt.t\n\n val add_level_info :\n predecessor:Block_hash.t -> context -> context tzresult 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 typed_transaction = {\n unparsed_parameters : Script.expr;\n unparsed_ty : Script.expr;\n destination : Contract_hash.t;\n entrypoint : Entrypoint.t;\n }\n\n type t =\n | Atomic_transaction_batch of {transactions : transaction list}\n | Atomic_transaction_batch_typed of {\n transactions : typed_transaction list;\n }\n | Whitelist_update of Whitelist.t option\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\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 type Generic_pvm_context_sig = 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 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 :\n is_reveal_enabled:is_reveal_enabled -> 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 :\n is_reveal_enabled:is_reveal_enabled ->\n input option ->\n proof ->\n input_request tzresult Lwt.t\n\n val produce_proof :\n context ->\n is_reveal_enabled:is_reveal_enabled ->\n input option ->\n state ->\n 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 -> output tzresult 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 | Riscv\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 val genesis_state_hash_of : boot_sector:string -> Kind.t -> State_hash.t Lwt.t\n\n module ArithPVM : sig\n module Make (C : Generic_pvm_context_sig) : 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 of Sc_rollup_PVM_sig.reveal\n | Parsing\n | Evaluating\n\n val get_status :\n is_reveal_enabled:is_reveal_enabled -> state -> status Lwt.t\n\n val get_outbox : Raw_level.t -> state -> output list 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 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 val decode_reveal : Wasm_2_0_0.reveal -> reveal\n\n module type Make_wasm = module type of Wasm_2_0_0.Make\n\n module Make (Wasm_backend : Make_wasm) (C : Generic_pvm_context_sig) : 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 :\n is_reveal_enabled:is_reveal_enabled -> state -> status Lwt.t\n\n val get_outbox : Raw_level.t -> state -> output list Lwt.t\n\n val produce_proof :\n context ->\n is_reveal_enabled:is_reveal_enabled ->\n input option ->\n state ->\n 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 end\n\n module Riscv_PVM : sig\n module Protocol_implementation :\n PVM.S\n with type context = unit\n and type state = Sc_rollup_riscv.minimal_state\n and type proof = Sc_rollup_riscv.void\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 with type t = Smart_rollup.Commitment_hash.t\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 ?whitelist:Whitelist.t ->\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 | Dal_parameters_proof\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\n val dal_number_of_slots : int\n\n val dal_activation_level : Raw_level.t option\n\n val dal_attested_slots_validity_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_activation_level:Raw_level.t option ->\n dal_attestation_lag:int ->\n dal_number_of_slots:int ->\n is_reveal_enabled:is_reveal_enabled ->\n dal_attested_slots_validity_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 is_reveal_enabled:is_reveal_enabled ->\n serialized t tzresult Lwt.t\n\n module Dal_helpers : sig\n val import_level_is_valid :\n dal_activation_level:Raw_level.t option ->\n dal_attestation_lag:int ->\n origination_level:Raw_level.t ->\n commit_inbox_level:Raw_level.t ->\n published_level:Raw_level.t ->\n dal_attested_slots_validity_lag:int ->\n bool\n end\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 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_activation_level:Raw_level.t option ->\n dal_attestation_lag:int ->\n dal_number_of_slots:int ->\n stakers:Index.t ->\n Metadata.t ->\n t ->\n step:step ->\n choice:Tick.t ->\n is_reveal_enabled:is_reveal_enabled ->\n dal_attested_slots_validity_lag:int ->\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 (context * Commitment.t * Commitment.Hash.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 find_game :\n context -> t -> Game.Index.t -> (context * Game.t option) 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 | 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 per_block_votes : Per_block_votes_repr.per_block_votes;\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\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 {!Operation_repr.Kind}. *)\nmodule Kind : sig\n type preattestation_consensus_kind = Preattestation_consensus_kind\n\n type attestation_consensus_kind = Attestation_consensus_kind\n\n type 'a consensus =\n | Preattestation_kind : preattestation_consensus_kind consensus\n | Attestation_kind : attestation_consensus_kind consensus\n\n type preattestation = preattestation_consensus_kind consensus\n\n type attestation = attestation_consensus_kind consensus\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_attestation_evidence =\n attestation_consensus_kind double_consensus_operation_evidence\n\n type double_preattestation_evidence =\n preattestation_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 transfer_ticket = Transfer_ticket_kind\n\n type dal_publish_commitment = Dal_publish_commitment_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 | Transfer_ticket_manager_kind : transfer_ticket manager\n | Dal_publish_commitment_manager_kind : dal_publish_commitment 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 | Attestation : Kind.attestation consensus_operation_type\n | Preattestation : Kind.preattestation consensus_operation_type\n\ntype consensus_content = {\n slot : Slot.t;\n level : Raw_level.t;\n (* The level is not required to validate an attestation when it corresponds\n to the current payload, but if we want to filter attestations, 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 dal_content = {attestation : Dal.Attestation.t}\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 | Preattestation : consensus_content -> Kind.preattestation contents\n | Attestation : {\n consensus_content : consensus_content;\n dal_content : dal_content option;\n }\n -> Kind.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_preattestation_evidence : {\n op1 : Kind.preattestation operation;\n op2 : Kind.preattestation operation;\n }\n -> Kind.double_preattestation_evidence contents\n | Double_attestation_evidence : {\n op1 : Kind.attestation operation;\n op2 : Kind.attestation operation;\n }\n -> Kind.double_attestation_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.t;\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.t;\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.t;\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 | 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_commitment :\n Dal.Operations.Publish_commitment.t\n -> Kind.dal_publish_commitment manager_operation\n | Sc_rollup_originate : {\n kind : Sc_rollup.Kind.t;\n boot_sector : string;\n parameters_ty : Script.lazy_expr;\n whitelist : Sc_rollup.Whitelist.t option;\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 }\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 val contents_encoding_with_legacy_attestation_name :\n 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 | Attestation of Chain_id.t\n | Preattestation 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 protocol_data_encoding_with_legacy_attestation_name :\n packed_protocol_data Data_encoding.t\n\n val unsigned_encoding :\n (Operation.shell_header * packed_contents_list) Data_encoding.t\n\n val unsigned_encoding_with_legacy_attestation_name :\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 val contents_list_encoding_with_legacy_attestation_name :\n 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 encoding_with_legacy_attestation_name : 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 unsigned_operation_length : _ operation -> int\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.preattestation case\n\n val preattestation_case : Kind.preattestation case\n\n val endorsement_case : Kind.attestation case\n\n val attestation_case : Kind.attestation case\n\n val endorsement_with_dal_case : Kind.attestation case\n\n val attestation_with_dal_case : Kind.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_preattestation_evidence case\n\n val double_preattestation_evidence_case :\n Kind.double_preattestation_evidence case\n\n val double_endorsement_evidence_case : Kind.double_attestation_evidence case\n\n val double_attestation_evidence_case : Kind.double_attestation_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 transfer_ticket_case : Kind.transfer_ticket Kind.manager case\n\n val dal_publish_commitment_case :\n Kind.dal_publish_commitment 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 transfer_ticket_case : Kind.transfer_ticket case\n\n val dal_publish_commitment_case : Kind.dal_publish_commitment 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 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\n\n (** See {!Delegate_sampler.load_sampler_for_cycle}. *)\n val load_sampler_for_cycle : context -> Cycle.t -> context tzresult Lwt.t\n\n val get_total_frozen_stake : context -> Cycle.t -> Tez.t tzresult Lwt.t\n\n module For_RPC : sig\n val delegate_current_baking_power :\n context -> Signature.public_key_hash -> int64 tzresult Lwt.t\n end\n\n module Internal_for_tests : sig\n val get_selected_distribution :\n context ->\n Cycle.t ->\n (Signature.public_key_hash * Stake_repr.t) list tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Commitment_repr} and,\n {!Commitment_storage}. *)\nmodule Commitment : sig\n type t = {blinded_public_key_hash : Blinded_public_key_hash.t; amount : Tez.t}\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\n\n val fold :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Blinded_public_key_hash.t -> Tez_repr.t -> 'a -> 'a Lwt.t) ->\n 'a Lwt.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_smart_contract:\n (context ->\n Script.t ->\n ((Script.t * Lazy_storage.diffs option) * context) tzresult Lwt.t) ->\n typecheck_smart_rollup:(context -> Script.expr -> context tzresult) ->\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 hash : Contract_hash.t option;\n }\n\n type bootstrap_smart_rollup = {\n address : Sc_rollup.Address.t;\n pvm_kind : Sc_rollup.Kind.t;\n boot_sector : string;\n parameters_ty : Script.lazy_expr;\n whitelist : Sc_rollup.Whitelist.t option;\n }\n\n type t = {\n bootstrap_accounts : bootstrap_account list;\n bootstrap_contracts : bootstrap_contract list;\n bootstrap_smart_rollups : bootstrap_smart_rollup 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 {!Votes_EMA_repr} *)\nmodule Votes_EMA : sig\n module type T = 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\n\n val update_ema_up : t -> t\n\n val update_ema_down : t -> t\n end\nend\n\n(** This module re-exports definitions from {!Per_block_votes_repr}. *)\nmodule Per_block_votes : sig\n type per_block_vote = Per_block_votes_repr.per_block_vote =\n | Per_block_vote_on\n | Per_block_vote_off\n | Per_block_vote_pass\n\n type per_block_votes = Per_block_votes_repr.per_block_votes = {\n liquidity_baking_vote : per_block_vote;\n adaptive_issuance_vote : per_block_vote;\n }\n\n val liquidity_baking_vote_encoding : per_block_vote Data_encoding.encoding\n\n val adaptive_issuance_vote_encoding : per_block_vote Data_encoding.encoding\n\n val per_block_votes_encoding : per_block_votes Data_encoding.encoding\n\n module Liquidity_baking_toggle_EMA : Votes_EMA.T\n\n module Adaptive_issuance_launch_EMA : Votes_EMA.T\n\n val compute_new_liquidity_baking_ema :\n per_block_vote:per_block_vote ->\n Liquidity_baking_toggle_EMA.t ->\n Liquidity_baking_toggle_EMA.t\n\n val compute_new_adaptive_issuance_ema :\n per_block_vote:per_block_vote ->\n Adaptive_issuance_launch_EMA.t ->\n Adaptive_issuance_launch_EMA.t\nend\n\n(** This module re-exports definitions from {!Liquidity_baking_storage}. *)\nmodule Liquidity_baking : sig\n val get_cpmm_address : context -> Contract_hash.t tzresult Lwt.t\n\n val on_subsidy_allowed :\n context ->\n per_block_vote:Per_block_votes.per_block_vote ->\n (context -> Contract_hash.t -> (context * 'a list) tzresult Lwt.t) ->\n (context * 'a list * Per_block_votes.Liquidity_baking_toggle_EMA.t) tzresult\n Lwt.t\nend\n\n(** This module re-exports definitions from {!Adaptive_issuance_storage}. *)\nmodule Adaptive_issuance : sig\n val update_ema :\n context ->\n vote:Per_block_votes.per_block_vote ->\n (context * Cycle.t option * Per_block_votes.Adaptive_issuance_launch_EMA.t)\n tzresult\n Lwt.t\n\n val launch_cycle : context -> Cycle.t option 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_attestation_branch context branch] sets the \"attestation branch\"\n (see {!Storage.Tenderbake.Attestation_branch} to [branch] in both the disk\n storage and RAM. *)\n val store_attestation_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 | `Frozen_deposits of Receipt.frozen_staker\n | `Unstaked_frozen_deposits of Receipt.unstaked_frozen_staker * Cycle.t\n | `Block_fees\n | `Frozen_bonds of Contract.t * Bond_id.t ]\n\n type giver =\n [ `Invoice\n | `Bootstrap\n | `Initial_commitments\n | `Revelation_rewards\n | `Attesting_rewards\n | `Baking_rewards\n | `Baking_bonuses\n | `Minted\n | `Liquidity_baking_subsidies\n | `Sc_rollup_refutation_rewards\n | container ]\n\n type receiver =\n [ `Storage_fees\n | `Double_signing_punishments\n | `Lost_attesting_rewards of public_key_hash * bool * bool\n | `Burned\n | `Sc_rollup_refutation_punishments\n | container ]\n\n val balance :\n context ->\n [< `Block_fees | `Collected_commitments of Blinded_public_key_hash.t] ->\n (context * Tez.t) tzresult Lwt.t\n\n val transfer_n :\n ?origin:Receipt.update_origin ->\n context ->\n ([< giver] * Tez.t) list ->\n [< receiver] ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n val transfer :\n ?origin:Receipt.update_origin ->\n context ->\n [< giver] ->\n [< receiver] ->\n Tez.t ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n module Internal_for_tests : sig\n val allocated : context -> container -> (context * bool) tzresult Lwt.t\n\n type container_with_balance =\n [ `Contract of Contract.t\n | `Collected_commitments of Blinded_public_key_hash.t\n | `Block_fees\n | `Frozen_bonds of Contract.t * Bond_id.t ]\n\n val balance :\n context -> [< container_with_balance] -> (context * Tez.t) tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Unstake_requests_storage}. *)\nmodule Unstake_requests : sig\n type finalizable = (public_key_hash * Cycle.t * Tez.t) list\n\n type stored_requests = private {\n delegate : public_key_hash;\n requests : (Cycle.t * Tez.t) list;\n }\n\n type prepared_finalize_unstake = {\n finalizable : finalizable;\n unfinalizable : stored_requests;\n }\n\n val prepared_finalize_unstake_encoding :\n prepared_finalize_unstake Data_encoding.encoding\n\n val prepare_finalize_unstake :\n context -> Contract.t -> prepared_finalize_unstake option tzresult Lwt.t\n\n module For_RPC : sig\n val apply_slash_to_unstaked_unfinalizable :\n context ->\n delegate:public_key_hash ->\n requests:(Cycle.t * Tez.t) list ->\n (Cycle.t * Tez.t) list tzresult Lwt.t\n\n val apply_slash_to_unstaked_unfinalizable_stored_requests :\n context -> stored_requests -> stored_requests tzresult Lwt.t\n end\nend\n\nmodule Unstaked_frozen_deposits : sig\n val balance : context -> public_key_hash -> Cycle.t -> Tez.t tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Staking_pseudotokens_storage}. *)\nmodule Staking_pseudotokens : sig\n module For_RPC : sig\n val staked_balance :\n context ->\n contract:Contract.t ->\n delegate:public_key_hash ->\n Tez.t tzresult Lwt.t\n\n val staking_pseudotokens_balance :\n context -> delegator:Contract.t -> Staking_pseudotoken.t tzresult Lwt.t\n\n val get_frozen_deposits_pseudotokens :\n context ->\n delegate:Signature.public_key_hash ->\n Staking_pseudotoken.t tzresult Lwt.t\n\n val get_frozen_deposits_staked_tez :\n context -> delegate:Signature.public_key_hash -> Tez.t tzresult Lwt.t\n end\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.giver ->\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.giver ->\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.giver ->\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.giver ->\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.giver ->\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\n module Whitelist = struct\n include Sc_rollup_whitelist_storage\n include Sc_rollup_whitelist_repr\n end\n\n module Metadata = Sc_rollup_metadata_repr\n module Dal_parameters = Sc_rollup_dal_parameters_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 Riscv_PVM = Sc_rollup_riscv\n\n module Inbox_message = struct\n include Sc_rollup_inbox_message_repr\n\n let protocol_migration_internal_message =\n Raw_context.protocol_migration_internal_message\n\n let protocol_migration_serialized_message =\n Raw_context.protocol_migration_serialized_message\n end\n\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 let genesis =\n genesis\n ~protocol_migration_message:\n Inbox_message.protocol_migration_serialized_message\n\n let add_all_messages ~first_block =\n add_all_messages\n ~protocol_migration_message:\n (if first_block then\n Some Inbox_message.protocol_migration_internal_message\n else None)\n\n module Internal_for_tests = struct\n include Sc_rollup_inbox_repr.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 include Raw_context.Dal\n\n module Slot_index = struct\n include Dal_slot_index_repr\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_index_repr.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 Operations = struct\n include Dal_operations_repr\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 let unsigned_encoding_with_legacy_attestation_name =\n unsigned_operation_encoding_with_legacy_attestation_name\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\n let from_repr (level : raw_level) = level\n\n let to_repr (level : raw_level) = level\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\n\n module Internal_for_tests = struct\n include Internal_for_tests\n\n let from_repr (round : round) = round\n\n let to_repr (round : round) = round\n end\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 let open Result_syntax in\n match raw_consume available_gas cost with\n | Some remaining_gas -> return remaining_gas\n | None -> tzfail 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 open Result_syntax in\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 let* ctxt = Raw_context.consume_gas ctxt gas_cost in\n let+ v = Script_repr.force_decode lexpr in\n (v, ctxt)\n\n let force_bytes_in_context ctxt lexpr =\n let open Result_syntax in\n let* ctxt =\n Raw_context.consume_gas ctxt (Script_repr.force_bytes_cost lexpr)\n in\n let+ v = Script_repr.force_bytes lexpr in\n (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 let is_delegate = Contract_delegate_storage.is_delegate\n\n type delegate_status = Contract_delegate_storage.delegate_status =\n | Delegate\n | Delegated of public_key_hash\n | Undelegated\n\n let get_delegate_status = Contract_delegate_storage.get_delegate_status\n\n module For_RPC = struct\n include Contract_storage.For_RPC\n include Delegate_slashed_deposits_storage.For_RPC\n end\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 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 let open Lwt_result_syntax in\n let*? c = Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost 0) in\n let* kt = Storage.Big_map.Key_type.find c id in\n match kt with\n | None -> return (c, None)\n | Some kt ->\n let+ kv = Storage.Big_map.Value_type.get c id in\n (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 = struct\n type unstaked_frozen_staker = Unstaked_frozen_staker_repr.t =\n | Single of Contract_repr.t * Signature.public_key_hash\n | Shared of Signature.public_key_hash\n\n type frozen_staker = Frozen_staker_repr.t = private\n | Baker of Signature.public_key_hash\n | Single_staker of {\n staker : Contract_repr.t;\n delegate : Signature.public_key_hash;\n }\n | Shared_between_stakers of {delegate : Signature.public_key_hash}\n | Baker_edge of Signature.public_key_hash\n\n let frozen_baker = Frozen_staker_repr.baker\n\n let frozen_baker_edge = Frozen_staker_repr.baker_edge\n\n let frozen_single_staker = Frozen_staker_repr.single_staker\n\n let frozen_shared_between_stakers = Frozen_staker_repr.shared_between_stakers\n\n include Receipt_repr\nend\n\nmodule Consensus_key = Delegate_consensus_key\nmodule Misbehaviour = Misbehaviour_repr\n\nmodule Delegate = struct\n include Delegate_storage\n include Delegate_missed_attestations_storage\n include Delegate_slashed_deposits_storage\n include Delegate_cycles\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 let is_forbidden_delegate = Forbidden_delegates_storage.is_forbidden\n\n let already_denounced = Already_denounced_storage.already_denounced\n\n module Consensus_key = Delegate_consensus_key\n\n module Rewards = struct\n include Delegate_rewards\n\n module For_RPC = struct\n include Delegate_rewards.For_RPC\n include Adaptive_issuance_storage.For_RPC\n end\n\n module Internal_for_tests = Adaptive_issuance_storage.Internal_for_tests\n end\n\n module Staking_parameters = Delegate_staking_parameters\n module Shared_stake = Shared_stake\n\n module For_RPC = struct\n include Delegate_storage.For_RPC\n include Delegate_slashed_deposits_storage.For_RPC\n include Delegate_missed_attestations_storage.For_RPC\n include Pending_denunciations_storage.For_RPC\n\n let pending_denunciations = Pending_denunciations_storage.find\n\n let has_pending_denunciations =\n Pending_denunciations_storage.has_pending_denunciations\n end\nend\n\nmodule Stake_distribution = struct\n let baking_rights_owner = Delegate_sampler.baking_rights_owner\n\n let slot_owner = Delegate_sampler.slot_owner\n\n let load_sampler_for_cycle = Delegate_sampler.load_sampler_for_cycle\n\n let get_total_frozen_stake ctxt cycle =\n let open Lwt_result_syntax in\n let* total_stake = Stake_storage.get_total_active_stake ctxt cycle in\n return (Stake_repr.get_frozen total_stake)\n\n module For_RPC = Delegate_sampler.For_RPC\n\n module Internal_for_tests = struct\n let get_selected_distribution = Stake_storage.get_selected_distribution\n end\nend\n\nmodule Staking = struct\n include Staking\n\n let stake = stake ~for_next_cycle_use_only_after_slashing:false\n\n let request_unstake =\n request_unstake ~for_next_cycle_use_only_after_slashing:false\n\n let finalize_unstake =\n finalize_unstake ~for_next_cycle_use_only_after_slashing:false\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_attestation_branch ctxt =\n let open Lwt_result_syntax in\n let* result = Storage.Tenderbake.Attestation_branch.find ctxt in\n match result with\n | Some attestation_branch ->\n Raw_context.Consensus.set_attestation_branch ctxt attestation_branch\n |> return\n | None -> return ctxt\n\n let store_attestation_branch ctxt branch =\n let ctxt = set_attestation_branch ctxt branch in\n Storage.Tenderbake.Attestation_branch.add ctxt branch\nend\n\nlet prepare_first_block = Init_storage.prepare_first_block\n\nlet prepare ctxt ~level ~predecessor_timestamp ~timestamp =\n let open Lwt_result_syntax in\n let* ctxt, balance_updates, origination_results =\n Init_storage.prepare ctxt ~level ~predecessor_timestamp ~timestamp\n in\n let* ctxt = Consensus.load_attestation_branch ctxt in\n let* ctxt = Forbidden_delegates_storage.load ctxt in\n let* ctxt = Adaptive_issuance_storage.load_reward_coeff ctxt in\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_finalized_block_level =\n Raw_level.to_int32 (Level.last_finalized_block_level c);\n last_preserved_block_level =\n Raw_level.to_int32 (Level.last_preserved_block_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\nmodule Votes_EMA = Votes_EMA_repr\nmodule Per_block_votes = Per_block_votes_repr\n\nmodule Liquidity_baking = struct\n include Liquidity_baking_storage\nend\n\nmodule Adaptive_issuance = struct\n include Adaptive_issuance_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 Unstake_requests = struct\n include Unstake_requests_storage\n\n let prepare_finalize_unstake =\n prepare_finalize_unstake ~for_next_cycle_use_only_after_slashing:false\n\n module For_RPC = struct\n let apply_slash_to_unstaked_unfinalizable ctxt ~delegate ~requests =\n Unstake_requests_storage.For_RPC.apply_slash_to_unstaked_unfinalizable\n ctxt\n {delegate; requests}\n\n let apply_slash_to_unstaked_unfinalizable_stored_requests ctxt\n {delegate; requests} =\n let open Lwt_result_syntax in\n let* requests =\n Unstake_requests_storage.For_RPC.apply_slash_to_unstaked_unfinalizable\n ctxt\n {delegate; requests}\n in\n return {delegate; requests}\n end\nend\n\nmodule Unstaked_frozen_deposits = Unstaked_frozen_deposits_storage\n\nmodule Staking_pseudotoken = struct\n include Staking_pseudotoken_repr\n module For_RPC = Staking_pseudotoken_repr\n module Internal_for_tests = Staking_pseudotoken_repr\nend\n\nmodule Staking_pseudotokens = struct\n include Staking_pseudotokens_storage\n module For_RPC = Staking_pseudotokens_storage.For_RPC\nend\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 open Result_syntax in\n let rec check_printable_ascii i =\n if Compare.Int.(i < 0) then return (String_tag v)\n else\n match v.[i] with\n | '\\n' | '\\x20' .. '\\x7E' -> check_printable_ascii (i - 1)\n | _ -> tzfail @@ 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 = "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 open Lwt_result_syntax in\n let ctxt = update_context gas_counter ctxt in\n let+ y, ctxt = f ctxt in\n (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 let open Result_syntax in\n match consume_opt local_gas_counter cost with\n | None -> tzfail Gas.Operation_quota_exceeded\n | Some local_gas_counter -> return 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\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 | Unexpected_implicit_account_parameters_type :\n Script.location * Script.expr\n -> 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\n result along with the new context with updated gas. If the given\n context has [unlimited] mode enabled, through [Gas.set_unlimited],\n 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 =\n let open Result_syntax in\n m gas >>?? fun (x, gas) ->\n of_result\n (let+ x in\n f x)\n 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 let open Result_syntax 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) -> return (res, ctxt)\n | None -> tzfail 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 return (res, ctxt)\n | None -> tzfail 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(** 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 let open Result_syntax in\n match annot with\n | [] -> return_unit\n | _ :: _ -> tzfail (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 open Result_syntax in\n let len = String.length s in\n let rec aux i =\n if Compare.Int.(i >= len) then return_unit\n else\n let* () = p s.[i] in\n 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 let open Result_syntax in\n if is_allowed_char c then return_unit else tzfail (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 let open Result_syntax in\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 -> return @@ 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 let* () = string_iter (check_char loc) (s :> string) 1 in\n return @@ wrap (Some s)\n | _ -> tzfail (Unexpected_annotation loc))\n in\n let len = String.length s in\n if Compare.Int.(len = 0 || len > max_annot_length) then\n tzfail (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 | _ -> tzfail (Unexpected_annotation loc)\n\nlet parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false)\n l =\n let open Result_syntax in\n List.map_e\n (function\n | \"@%\" when allow_special_var -> return @@ Var_annot_opt (Some Var_annot)\n | \"@%%\" when allow_special_var -> return @@ Var_annot_opt (Some Var_annot)\n | \"%@\" when allow_special_field -> return @@ 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 let open Result_syntax in\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 return (List.rev rv, List.rev rt, List.rev rf)\n with Exit -> tzfail (Ungrouped_annotations loc)\n\nlet get_one_annot loc =\n let open Result_syntax in\n function\n | [] -> return_none\n | [a] -> return a\n | _ -> tzfail (Unexpected_annotation loc)\n\nlet get_two_annot loc =\n let open Result_syntax in\n function\n | [] -> return (None, None)\n | [a] -> return (a, None)\n | [a; b] -> return (a, b)\n | _ -> tzfail (Unexpected_annotation loc)\n\nlet check_type_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc vars in\n let* () = error_unexpected_annot loc fields in\n let+ (_a : type_annot option) = get_one_annot loc types in\n ()\n\nlet parse_field_annot :\n Script.location -> string -> Non_empty_string.t option tzresult =\n let open Result_syntax in\n fun loc annot ->\n if Compare.Int.(String.length annot <= 0) || Compare.Char.(annot.[0] <> '%')\n then return_none\n else\n let+ annot_opt = parse_annot loc annot in\n match annot_opt with Field_annot_opt annot_opt -> annot_opt | _ -> None\n\nlet is_field_annot loc a =\n let open Result_syntax in\n let+ result = parse_field_annot loc a in\n Option.is_some result\n\nlet extract_field_annot :\n Script.node -> (Script.node * Non_empty_string.t option) tzresult =\n let open Result_syntax in\n function\n | Prim (loc, prim, args, annot) as expr ->\n let rec extract_first acc = function\n | [] -> return (expr, None)\n | s :: rest -> (\n let* str_opt = parse_field_annot loc s in\n match str_opt with\n | None -> extract_first (s :: acc) rest\n | Some _ as some_field_annot ->\n let annot = List.rev_append acc rest in\n return (Prim (loc, prim, args, annot), some_field_annot))\n in\n extract_first [] annot\n | expr -> return (expr, None)\n\nlet has_field_annot node =\n let open Result_syntax in\n let+ _node, result = extract_field_annot node in\n Option.is_some result\n\nlet remove_field_annot node =\n let open Result_syntax in\n let+ node, _a = extract_field_annot node in\n node\n\nlet extract_entrypoint_annot node =\n let open Result_syntax in\n let+ node, field_annot_opt = extract_field_annot node in\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 let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc types in\n let* () = error_unexpected_annot loc fields in\n let+ (_a : var_annot option) = get_one_annot loc vars in\n ()\n\nlet check_constr_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots ~allow_special_field:true loc annot in\n classify_annot loc annots\n in\n let* (_v : var_annot option) = get_one_annot loc vars in\n let* (_t : type_annot option) = get_one_annot loc types in\n let+ _f1, _f2 = get_two_annot loc fields in\n ()\n\nlet check_two_var_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc types in\n let* () = error_unexpected_annot loc fields in\n let+ _a1, _a2 = get_two_annot loc vars in\n ()\n\nlet check_destr_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc ~allow_special_var:true annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc types in\n let* (_v : var_annot option) = get_one_annot loc vars in\n let+ (_f : field_annot option) = get_one_annot loc fields in\n ()\n\nlet check_unpair_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc ~allow_special_var:true annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc types in\n let* _vcar, _vcdr = get_two_annot loc vars in\n let+ _f1, _f2 = get_two_annot loc fields in\n ()\n\nlet parse_entrypoint_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc types in\n let* f = get_one_annot loc fields in\n let+ (_v : var_annot option) = get_one_annot loc vars in\n f\n\nlet parse_entrypoint_annot_strict loc annot =\n let open Result_syntax in\n let* entrypoint_annot = parse_entrypoint_annot loc annot in\n match entrypoint_annot with\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 let open Result_syntax in\n let* entrypoint_annot = parse_entrypoint_annot loc annot in\n match entrypoint_annot with\n | None -> Ok Entrypoint.default\n | Some (Field_annot annot) -> Entrypoint.of_annot_lax annot\n\nlet check_var_type_annot loc annot =\n let open Result_syntax in\n let* vars, types, fields =\n let* annots = parse_annots loc annot in\n classify_annot loc annots\n in\n let* () = error_unexpected_annot loc fields in\n let* (_v : var_annot option) = get_one_annot loc vars in\n let+ (_t : type_annot option) = get_one_annot loc types in\n ()\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 `sender`, `self`, and `amount` and the KView_exit continuation\n which restores them.\n ======================\n\n*)\ntype step_constants = {\n sender : 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 ('a, 'b) pair = 'a * 'b\n\ntype ('a, 'b) or_ = 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-or nodes.\n But it is also ok to have [Entrypoints_None] for an or 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_Or : {\n left : 'l entrypoints_node;\n right : 'r entrypoints_node;\n }\n -> ('l, 'r) or_ 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, ... 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 | IPush :\n Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 'S, 'r, 'F) kinstr\n -> ('a, 'S, 'r, 'F) kinstr\n | IUnit :\n Script.location * (unit, 'a * 'S, 'r, 'F) kinstr\n -> ('a, 'S, 'r, 'F) kinstr\n (*\n Pairs\n -----\n *)\n | ICons_pair :\n Script.location * (('a, 'b) pair, '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) pair, 'S, 'r, 'F) kinstr\n | ICdr :\n Script.location * ('b, 'S, 'r, 'F) kinstr\n -> (('a, 'b) pair, 'S, 'r, 'F) kinstr\n | IUnpair :\n Script.location * ('a, 'b * 'S, 'r, 'F) kinstr\n -> (('a, 'b) pair, '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, 'F) kinstr;\n }\n -> ('a option, 'S, 'c, 'F) kinstr\n (*\n Ors\n ------\n *)\n | ICons_left :\n Script.location * ('b, _) ty * (('a, 'b) or_, 'c * 'S, 'r, 'F) kinstr\n -> ('a, 'c * 'S, 'r, 'F) kinstr\n | ICons_right :\n Script.location * ('a, _) ty * (('a, 'b) or_, '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) or_, '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) pair, '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) pair, _) ty option\n * (('a, 'b) pair, '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, 'T) kinstr;\n branch_if_false : ('a, 'S, 'b, 'T) kinstr;\n k : ('b, 'T, '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) or_, 'S) kinstr\n * ('b, 'S, 'r, 'F) kinstr\n -> (('a, 'b) or_, '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) pair, '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) pair) pair, 'a ticket * 'S, 'r, 'F) kinstr\n -> ('a ticket, 'S, 'r, 'F) kinstr\n | ISplit_ticket :\n Script.location * (('a ticket, 'a ticket) pair option, 'S, 'r, 'F) kinstr\n -> ('a ticket, (n num, n num) pair * '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) pair, 'S, 'r, 'F) kinstr\n | IOpen_chest :\n Script.location * (bytes option, '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_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) or_, 'S) kinstr * ('b, 'S, 'r, 'F) continuation\n -> (('a, 'b) or_, '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) pair, '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) pair, '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 | 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 | Or_t :\n ('a, 'ac) ty\n * ('b, 'bc) ty\n * ('a, 'b) or_ ty_metadata\n * ('ac, 'bc, 'rc) dand\n -> (('a, 'b) or_, '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) pair, '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) pair, 'a) comb_get_gadt_witness\n | Comb_get_plus_two :\n ('before, 'after) comb_get_gadt_witness\n -> (('a, 'before) pair, '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\n : ('value, ('hd, 'tl) pair, ('value, 'tl) pair) comb_set_gadt_witness\n | Comb_set_plus_two :\n ('value, 'before, 'after) comb_set_gadt_witness\n -> ('value, ('a, 'before) pair, ('a, 'after) pair) 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.t;\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.t;\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.t;\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_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.t;\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 sender : 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 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 pair_int_int_unit_t : (z num, (z num, unit) pair) pair comparable_ty\n\nval or_t :\n Script.location -> ('a, _) ty -> ('b, _) ty -> ('a, 'b) or_ ty_ex_c tzresult\n\nval comparable_or_t :\n Script.location ->\n 'a comparable_ty ->\n 'b comparable_ty ->\n ('a, 'b) or_ comparable_ty tzresult\n\nval or_bytes_bool_t : (Bytes.t, bool) or_ 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, stack_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 'S 'r 'F. 'a -> ('b, 'S, 'r, 'F) kinstr -> 'a;\n}\n\nval kinstr_traverse :\n ('a, 'S, 'c, 'F) 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 `sender`, `self`, and `amount` and the KView_exit continuation\n which restores them.\n ======================\n\n*)\ntype step_constants = {\n sender : 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\ntype ('a, 'b) pair = 'a * 'b\n\n(* We cannot call this type \"or\" as in Michelson because \"or\" is an\n OCaml keyword. *)\ntype ('a, 'b) or_ = 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 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 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 open Result_syntax in\n let max_size = Constants.michelson_maximum_type_size in\n if Compare.Int.(size <= max_size) then return size\n else tzfail (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_Or : {\n left : 'l entrypoints_node;\n right : 'r entrypoints_node;\n }\n -> ('l, 'r) or_ 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 | IPush :\n Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 'S, 'r, 'F) kinstr\n -> ('a, 'S, 'r, 'F) kinstr\n | IUnit :\n Script.location * (unit, 'a * 'S, 'r, 'F) kinstr\n -> ('a, 'S, 'r, 'F) kinstr\n (*\n Pairs\n -----\n *)\n | ICons_pair :\n Script.location * (('a, 'b) pair, '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) pair, 'S, 'r, 'F) kinstr\n | ICdr :\n Script.location * ('b, 'S, 'r, 'F) kinstr\n -> (('a, 'b) pair, 'S, 'r, 'F) kinstr\n | IUnpair :\n Script.location * ('a, 'b * 'S, 'r, 'F) kinstr\n -> (('a, 'b) pair, '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, 'F) kinstr;\n }\n -> ('a option, 'S, 'c, 'F) kinstr\n (*\n Ors\n ------\n *)\n | ICons_left :\n Script.location * ('b, _) ty * (('a, 'b) or_, 'c * 'S, 'r, 'F) kinstr\n -> ('a, 'c * 'S, 'r, 'F) kinstr\n | ICons_right :\n Script.location * ('a, _) ty * (('a, 'b) or_, '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) or_, '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) pair, '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) pair, _) ty option\n * (('a, 'b) pair, '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, 'T) kinstr;\n branch_if_false : ('a, 'S, 'b, 'T) kinstr;\n k : ('b, 'T, '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) or_, 'S) kinstr\n * ('b, 'S, 'r, 'F) kinstr\n -> (('a, 'b) or_, '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) pair, '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) pair) pair, 'a ticket * 'S, 'r, 'F) kinstr\n -> ('a ticket, 'S, 'r, 'F) kinstr\n | ISplit_ticket :\n Script.location * (('a ticket, 'a ticket) pair option, 'S, 'r, 'F) kinstr\n -> ('a ticket, (n num, n num) pair * '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) pair, 'S, 'r, 'F) kinstr\n | IOpen_chest :\n Script.location * (bytes option, '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_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) or_, 'S) kinstr * ('b, 'S, 'r, 'F) continuation\n -> (('a, 'b) or_, '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) pair, 'd * 'S, 'c, 'd * 'S) kinstr\n * ('a, 'b) pair 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) pair, 'd * 'S, 'c, 'd * 'S) kinstr\n * ('a, 'b) pair 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 | 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 | Or_t :\n ('a, 'ac) ty\n * ('b, 'bc) ty\n * ('a, 'b) or_ ty_metadata\n * ('ac, 'bc, 'rc) dand\n -> (('a, 'b) or_, '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) pair, '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) pair, 'a) comb_get_gadt_witness\n | Comb_get_plus_two :\n ('before, 'after) comb_get_gadt_witness\n -> (('a, 'before) pair, '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\n : ('value, ('hd, 'tl) pair, ('value, 'tl) pair) comb_set_gadt_witness\n | Comb_set_plus_two :\n ('value, 'before, 'after) comb_set_gadt_witness\n -> ('value, ('a, 'before) pair, ('a, 'after) pair) 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.t;\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.t;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_smart_contract : {\n destination : Contract_hash.t;\n amount : Tez.t;\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_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.t;\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 sender : 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_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 | IPush (loc, _, _, _) -> loc\n | IUnit (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 meta_compound1 loc ({size} : _ ty_metadata) : _ ty_metadata tzresult =\n let open Result_syntax in\n let+ size = Type_size.compound1 loc size in\n {size}\n\nlet meta_compound2 loc ({size = size1} : _ ty_metadata)\n ({size = size2} : _ ty_metadata) : _ ty_metadata tzresult =\n let open Result_syntax in\n let+ size = Type_size.compound2 loc size1 size2 in\n {size}\n\nlet unit_metadata : unit ty_metadata = meta_basic\n\nlet never_metadata : never ty_metadata = meta_basic\n\nlet int_metadata : z num ty_metadata = meta_basic\n\nlet nat_metadata : n num ty_metadata = meta_basic\n\nlet signature_metadata : signature ty_metadata = meta_basic\n\nlet string_metadata : Script_string.t ty_metadata = meta_basic\n\nlet bytes_metadata : bytes ty_metadata = meta_basic\n\nlet mutez_metadata : Tez.t ty_metadata = meta_basic\n\nlet bool_metadata : bool ty_metadata = meta_basic\n\nlet key_hash_metadata : public_key_hash ty_metadata = meta_basic\n\nlet key_metadata : public_key ty_metadata = meta_basic\n\nlet timestamp_metadata : Script_timestamp.t ty_metadata = meta_basic\n\nlet chain_id_metadata : Script_chain_id.t ty_metadata = meta_basic\n\nlet address_metadata : address ty_metadata = meta_basic\n\nlet sapling_transaction_metadata : Sapling.transaction ty_metadata = meta_basic\n\nlet sapling_transaction_deprecated_metadata :\n Sapling.Legacy.transaction ty_metadata =\n meta_basic\n\nlet sapling_state_metadata : Sapling.state ty_metadata = meta_basic\n\nlet operation_metadata : operation ty_metadata = meta_basic\n\nlet bls12_381_g1_metadata : Script_bls.G1.t ty_metadata = meta_basic\n\nlet bls12_381_g2_metadata : Script_bls.G2.t ty_metadata = meta_basic\n\nlet bls12_381_fr_metadata : Script_bls.Fr.t ty_metadata = meta_basic\n\nlet chest_metadata : Script_timelock.chest ty_metadata = meta_basic\n\nlet chest_key_metadata : Script_timelock.chest_key ty_metadata = meta_basic\n\nlet pair_metadata :\n Script.location ->\n 'a ty_metadata ->\n 'b ty_metadata ->\n ('a, 'b) pair ty_metadata tzresult =\n meta_compound2\n\nlet or_metadata :\n Script.location ->\n 'a ty_metadata ->\n 'b ty_metadata ->\n ('a, 'b) or_ ty_metadata tzresult =\n meta_compound2\n\nlet lambda_metadata :\n Script.location ->\n 'a ty_metadata ->\n 'b ty_metadata ->\n ('a, 'b) lambda ty_metadata tzresult =\n meta_compound2\n\nlet option_metadata :\n Script.location -> 'a ty_metadata -> 'a option ty_metadata tzresult =\n meta_compound1\n\nlet list_metadata :\n Script.location -> 'a ty_metadata -> 'a Script_list.t ty_metadata tzresult =\n meta_compound1\n\nlet set_metadata :\n Script.location -> 'a ty_metadata -> 'a set ty_metadata tzresult =\n meta_compound1\n\nlet map_metadata :\n Script.location ->\n 'a ty_metadata ->\n 'b ty_metadata ->\n ('a, 'b) map ty_metadata tzresult =\n meta_compound2\n\nlet big_map_metadata :\n Script.location ->\n 'a ty_metadata ->\n 'b ty_metadata ->\n ('a, 'b) big_map ty_metadata tzresult =\n meta_compound2\n\nlet contract_metadata :\n Script.location -> 'a ty_metadata -> 'a typed_contract ty_metadata tzresult\n =\n meta_compound1\n\nlet ticket_metadata :\n Script.location -> 'a ty_metadata -> 'a ticket ty_metadata tzresult =\n meta_compound1\n\nlet ty_metadata : type a ac. (a, ac) ty -> a ty_metadata = function\n | Unit_t -> unit_metadata\n | Never_t -> never_metadata\n | Int_t -> int_metadata\n | Nat_t -> nat_metadata\n | Signature_t -> signature_metadata\n | String_t -> string_metadata\n | Bytes_t -> bytes_metadata\n | Mutez_t -> mutez_metadata\n | Bool_t -> bool_metadata\n | Key_hash_t -> key_hash_metadata\n | Key_t -> key_metadata\n | Timestamp_t -> timestamp_metadata\n | Chain_id_t -> chain_id_metadata\n | Address_t -> address_metadata\n | Pair_t (_, _, meta, _) -> meta\n | Or_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_metadata\n | Sapling_transaction_deprecated_t _ ->\n sapling_transaction_deprecated_metadata\n | Sapling_state_t _ -> sapling_state_metadata\n | Operation_t -> operation_metadata\n | Bls12_381_g1_t -> bls12_381_g1_metadata\n | Bls12_381_g2_t -> bls12_381_g2_metadata\n | Bls12_381_fr_t -> bls12_381_fr_metadata\n | Chest_t -> chest_metadata\n | Chest_key_t -> chest_key_metadata\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 | Pair_t (_, _, _, dand) -> dbool_of_dand dand\n | Or_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 assert_ok1 f x =\n match f Micheline.dummy_location x with\n | Ok res -> res\n | Error _ -> assert false\n\nlet assert_ok2 f x y =\n match f Micheline.dummy_location x y with\n | Ok res -> res\n | Error _ -> assert false\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 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 let open Result_syntax in\n let+ metadata = pair_metadata loc (ty_metadata l) (ty_metadata r) in\n let (Ex_dand cmp) = dand (is_comparable l) (is_comparable r) in\n Ty_ex_c (Pair_t (l, r, metadata, cmp))\n\nlet pair_3_t loc l m r =\n let open Result_syntax in\n let* (Ty_ex_c r) = pair_t loc m r in\n pair_t loc l r\n\nlet comparable_pair_t loc l r =\n let open Result_syntax in\n let+ metadata = pair_metadata loc (ty_metadata l) (ty_metadata r) in\n Pair_t (l, r, metadata, YesYes)\n\nlet comparable_pair_3_t loc l m r =\n let open Result_syntax in\n let* r = comparable_pair_t loc m r in\n comparable_pair_t loc l r\n\nlet pair_int_int_unit_t =\n let iu_metadata = assert_ok2 pair_metadata int_metadata unit_metadata in\n let iiu_metadata = assert_ok2 pair_metadata int_metadata iu_metadata in\n Pair_t\n (int_t, Pair_t (int_t, unit_t, iu_metadata, YesYes), iiu_metadata, YesYes)\n\nlet or_t :\n type a ac b bc.\n Script.location -> (a, ac) ty -> (b, bc) ty -> (a, b) or_ ty_ex_c tzresult =\n let open Result_syntax in\n fun loc l r ->\n let+ metadata = or_metadata loc (ty_metadata l) (ty_metadata r) in\n let (Ex_dand cmp) = dand (is_comparable l) (is_comparable r) in\n Ty_ex_c (Or_t (l, r, metadata, cmp))\n\nlet or_bytes_bool_t =\n Or_t\n ( bytes_t,\n bool_t,\n assert_ok2 or_metadata bytes_metadata bool_metadata,\n YesYes )\n\nlet comparable_or_t loc l r =\n let open Result_syntax in\n let+ metadata = or_metadata loc (ty_metadata l) (ty_metadata r) in\n Or_t (l, r, metadata, YesYes)\n\nlet lambda_t loc l r =\n let open Result_syntax in\n let+ metadata = lambda_metadata loc (ty_metadata l) (ty_metadata r) in\n Lambda_t (l, r, metadata)\n\nlet option_t loc t =\n let open Result_syntax in\n let+ metadata = option_metadata loc (ty_metadata t) in\n let cmp = is_comparable t in\n Option_t (t, metadata, cmp)\n\nlet option_mutez_t =\n Option_t (mutez_t, assert_ok1 option_metadata mutez_metadata, Yes)\n\nlet option_string_t =\n Option_t (string_t, assert_ok1 option_metadata string_metadata, Yes)\n\nlet option_bytes_t =\n Option_t (bytes_t, assert_ok1 option_metadata bytes_metadata, Yes)\n\nlet option_nat_t = Option_t (nat_t, assert_ok1 option_metadata nat_metadata, Yes)\n\nlet option_pair_nat_nat_t =\n let pmetadata = assert_ok2 pair_metadata nat_metadata nat_metadata in\n let ometadata = assert_ok1 option_metadata pmetadata in\n Option_t (Pair_t (nat_t, nat_t, pmetadata, YesYes), ometadata, Yes)\n\nlet option_pair_nat_mutez_t =\n let pmetadata = assert_ok2 pair_metadata nat_metadata mutez_metadata in\n let ometadata = assert_ok1 option_metadata pmetadata in\n Option_t (Pair_t (nat_t, mutez_t, pmetadata, YesYes), ometadata, Yes)\n\nlet option_pair_mutez_mutez_t =\n let pmetadata = assert_ok2 pair_metadata mutez_metadata mutez_metadata in\n let ometadata = assert_ok1 option_metadata pmetadata in\n Option_t (Pair_t (mutez_t, mutez_t, pmetadata, YesYes), ometadata, Yes)\n\nlet option_pair_int_nat_t =\n let pmetadata = assert_ok2 pair_metadata int_metadata nat_metadata in\n let ometadata = assert_ok1 option_metadata pmetadata in\n Option_t (Pair_t (int_t, nat_t, pmetadata, YesYes), ometadata, Yes)\n\nlet list_t loc t =\n let open Result_syntax in\n let+ metadata = list_metadata loc (ty_metadata t) in\n List_t (t, metadata)\n\nlet operation_t = Operation_t\n\nlet list_operation_t =\n List_t (operation_t, assert_ok1 list_metadata operation_metadata)\n\nlet set_t loc t =\n let open Result_syntax in\n let+ metadata = set_metadata loc (ty_metadata t) in\n Set_t (t, metadata)\n\nlet map_t loc l r =\n let open Result_syntax in\n let+ metadata = map_metadata loc (ty_metadata l) (ty_metadata r) in\n Map_t (l, r, metadata)\n\nlet big_map_t loc l r =\n let open Result_syntax in\n let+ metadata = big_map_metadata loc (ty_metadata l) (ty_metadata r) in\n Big_map_t (l, r, metadata)\n\nlet contract_t loc t =\n let open Result_syntax in\n let+ metadata = contract_metadata loc (ty_metadata t) in\n Contract_t (t, metadata)\n\nlet contract_unit_t =\n Contract_t (unit_t, assert_ok1 contract_metadata unit_metadata)\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 let open Result_syntax in\n let+ metadata = ticket_metadata loc (ty_metadata t) in\n Ticket_t (t, metadata)\n\nlet chest_key_t = Chest_key_t\n\nlet chest_t = Chest_t\n\ntype 'a kinstr_traverse = {\n apply : 'b 'S 'r 'F. 'a -> ('b, 'S, '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 | IPush (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IUnit (_, 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 | Bool_t\n | 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 [@ocaml.tailcall]) 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 | Or_t (ty1, ty2, _, _) -> (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, _, _) -> (aux [@ocaml.tailcall]) f accu ty1 continue\n | List_t (ty1, _) -> (aux [@ocaml.tailcall]) f accu ty1 continue\n | Set_t (cty, _) -> (aux [@ocaml.tailcall]) f accu cty continue\n | Map_t (cty, ty1, _) -> (next2 [@ocaml.tailcall]) f accu cty ty1 continue\n | Big_map_t (cty, ty1, _) ->\n (next2 [@ocaml.tailcall]) f accu cty ty1 continue\n | Contract_t (ty1, _) -> (aux [@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 continue)\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 | Bool_t\n | 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 | Or_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_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_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_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 | 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" ;
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\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 | 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 | Or_t (tl, _, _, YesYes), L x, L y ->\n (compare_comparable [@tailcall]) tl k x y\n | Or_t _, L _, R _ -> -1\n | Or_t _, R _, L _ -> 1\n | Or_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.t -> 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.t) : 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 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 | 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 | Or_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 let open Lwt_result_syntax in\n fun f ctxt (Map_tag (module Box)) ->\n let+ map, ctxt =\n Box.OPS.fold_es\n (fun key value (map, ctxt) ->\n let+ value, ctxt = f ctxt key value in\n (Box.OPS.add key value map, ctxt))\n Box.boxed\n (Box.OPS.empty, ctxt)\n in\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 | 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 | Or_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 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_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 ciphertext : ciphertext;\n }\n *)\n let locked_value_size = 256 in\n let ciphertext_size = Script_timelock.get_plaintext_size chest in\n h3w +? (locked_value_size + ciphertext_size)\n\nlet chest_key_size _ =\n (*\n type chest_key = {\n vdf_tuple : vdf_tuple; a record of 3 group elements, each of size 256 bytes\n nonce : Z.t; RSA modulus size (256 bytes) + 128 bits\n }\n *)\n let vdf_tuple_size = 3 * 256 in\n let nonce_size = 256 + 16 in\n h2w +? (vdf_tuple_size + nonce_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 | Bool_t -> ret_succ accu\n | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w\n | Or_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 | IPush (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 | IUnit (loc, k) -> ret_succ_adding accu (base1 loc k)\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_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model script_typed_ir_size/KINSTR_SIZE *)\n(* fun size -> max 10 (0. + (16.9107287794 * size)) *)\nlet cost_KINSTR_SIZE size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 17)\n\n(* model script_typed_ir_size/NODE_SIZE *)\n(* fun size -> max 10 (0. + (25.3968974269 * size)) *)\nlet cost_NODE_SIZE size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) ((size lsr 1) + (size * S.safe_int 25))\n\n(* model script_typed_ir_size/TYPE_SIZE *)\n(* fun size -> max 10 (0. + (16.223250671 * size)) *)\nlet cost_TYPE_SIZE size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) ((size lsr 1) + (size * S.safe_int 16))\n\n(* model script_typed_ir_size/VALUE_SIZE *)\n(* fun size -> max 10 (0. + (19.5698881074 * size)) *)\nlet cost_VALUE_SIZE size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 20)\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(** [nodes_cost ~nodes] returns the cost of having called\n a function in {!Script_typed_ir_size} that returns [nodes], i.e.\n [value_size], [lambda_size] and [node_size]\n*)\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\ninclude Script_typed_ir_size_costs_generated\n\n(* [coeff] should be the maximum of\n [script_typed_ir_size/KINSTR_SIZE_size_coeff]\n [script_typed_ir_size/NODE_SIZE_ns_per_node_coeff]\n [script_typed_ir_size/TYPE_SIZE_size_coeff]\n [script_typed_ir_size/VALUE_SIZE_size_coeff]\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.Syntax in\n let nodes = Cache_memory_helpers.Nodes.to_int nodes in\n let coeff = S.safe_int 45 in\n coeff * S.safe_int nodes |> Gas_limit_repr.atomic_step_cost\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 (* The [manager_operation] cost is consumed each time a manager\n operation (internal or external alike) is applied. This cost is\n meant to cover the resources used in {!Apply} either directly\n (dispatching on operation kinds) or indirectly (in particular in\n the production of operation results). *)\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 type algo = Ed25519 | Secp256k1 | P256 | Bls\n\n val algo_of_public_key : Signature.public_key -> algo\n\n val algo_of_public_key_hash : Signature.public_key_hash -> algo\n\n val check_signature_on_algo : algo -> int -> 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 push : Gas.cost\n\n val unit : 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 : ('k, 'v) Script_typed_ir.map -> 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 ty_eq : _ Script_typed_ir.ty -> _ Script_typed_ir.ty -> Gas.cost\n\n val ty_eq_prim : 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 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 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 = 100\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 (* The uses of [cost_N_IMap_*] below are intentional. They are for\n the cost of the big_map overlay. The other costs such as the storage\n access and the deserialization are separately charged in the protocol.\n We don't use [cost_N_IBig_map_*] here, since they include these partial\n carbonations. *)\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 type algo = Ed25519 | Secp256k1 | P256 | Bls\n\n let algo_of_public_key (pkey : Signature.public_key) =\n match pkey with\n | Ed25519 _ -> Ed25519\n | Secp256k1 _ -> Secp256k1\n | P256 _ -> P256\n | Bls _ -> Bls\n\n let algo_of_public_key_hash (pkh : Signature.public_key_hash) =\n match pkh with\n | Ed25519 _ -> Ed25519\n | Secp256k1 _ -> Secp256k1\n | P256 _ -> P256\n | Bls _ -> Bls\n\n let check_signature_on_algo algo length =\n match algo with\n | Ed25519 -> cost_N_ICheck_signature_ed25519 length\n | Secp256k1 -> cost_N_ICheck_signature_secp256k1 length\n | P256 -> cost_N_ICheck_signature_p256 length\n | Bls -> cost_N_ICheck_signature_bls length\n\n let check_signature pkey b =\n check_signature_on_algo (algo_of_public_key pkey) (Bytes.length b)\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\n (cost_N_ISapling_verify_update_with_blake2b inputs outputs bound_data)\n\n let sapling_verify_update_deprecated ~inputs ~outputs =\n atomic_step_cost\n (cost_N_ISapling_verify_update_with_blake2b 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 push = atomic_step_cost cost_N_IPush\n\n let unit = atomic_step_cost cost_N_IUnit\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_or_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 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 | 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 | Or_t (tl, tr, _, YesYes) -> (\n match (x, y) with\n | L x, L y ->\n (compare [@tailcall]) tl x y Gas.(acc +@ compare_or_tag) k\n | L _, R _ -> (apply [@tailcall]) Gas.(acc +@ compare_or_tag) k\n | R _, L _ -> (apply [@tailcall]) Gas.(acc +@ compare_or_tag) k\n | R x, R y ->\n (compare [@tailcall]) tr x y Gas.(acc +@ compare_or_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 (module Box) = Script_set.get set in\n let per_elt_cost = Box.OPS.elt_size elt |> Size.to_int in\n Michelson_v1_gas_costs.cost_N_ISet_mem per_elt_cost Box.size\n\n let set_update (type a) (elt : a) (set : a Script_typed_ir.set) =\n let (module Box) = Script_set.get set in\n let per_elt_cost = Box.OPS.elt_size elt |> Size.to_int in\n Michelson_v1_gas_costs.cost_N_ISet_update per_elt_cost Box.size\n\n let map_mem (type k v) (elt : k) (map : (k, v) Script_typed_ir.map) =\n let (module Box) = Script_map.get_module map in\n let per_elt_cost = Box.OPS.key_size elt in\n Michelson_v1_gas_costs.cost_N_IMap_mem per_elt_cost Box.size\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 (module Box) = Script_map.get_module map in\n let per_elt_cost = Box.OPS.key_size elt in\n Michelson_v1_gas_costs.cost_N_IMap_update per_elt_cost Box.size\n\n let map_get_and_update (type k v) (elt : k)\n (map : (k, v) Script_typed_ir.map) =\n let (module Box) = Script_map.get_module map in\n let per_elt_cost = Box.OPS.key_size elt in\n Michelson_v1_gas_costs.cost_N_IMap_get_and_update per_elt_cost Box.size\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 (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_KMap_enter_body Box.size)\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 let concat_string_precheck (l : 'a Script_list.t) =\n atomic_step_cost (cost_N_IConcat_string_precheck l.length)\n\n let concat_string total_bytes =\n atomic_step_cost (cost_N_IConcat_string total_bytes)\n\n let concat_bytes total_bytes =\n atomic_step_cost (cost_N_IConcat_bytes total_bytes)\n\n let unpack bytes =\n let blen = Bytes.length bytes in\n atomic_step_cost (cost_N_IUnpack blen)\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 ty_eq ty1 ty2 =\n (* Assumes O(1) access to the size of a type *)\n let size1 = Script_typed_ir.(ty_size ty1 |> Type_size.to_int) in\n let size2 = Script_typed_ir.(ty_size ty2 |> Type_size.to_int) in\n atomic_step_cost (cost_TY_EQ (Saturation_repr.min size1 size2))\n\n (* The gas cost for comparing a type with a type of size 1 *)\n let ty_eq_prim = atomic_step_cost (cost_TY_EQ (Saturation_repr.safe_int 1))\n\n let parse_type_cycle = atomic_step_cost cost_PARSE_TYPE1\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 (* 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 @@ cost_UNPARSE_TYPE\n @@ Script_typed_ir.(Type_size.to_int @@ ty_size ty)\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 (* 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 = "Operation_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 check_signature_cost :\n Michelson_v1_gas.Cost_of.Interpreter.algo -> _ operation -> Gas.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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\nmodule S = Saturation_repr\nmodule I = Michelson_v1_gas.Cost_of.Interpreter\n\n(* TODO:\n https://gitlab.com/tezos/tezos/-/issues/5141\n benchmark this. *)\nlet serialization_cost size =\n let open S.Syntax in\n let v0 = S.safe_int size in\n v0 lsl 5\n\nlet check_signature_cost (algo : I.algo) (operation : _ operation) =\n let open S.Syntax in\n let size = Operation.unsigned_operation_length operation in\n Gas.atomic_step_cost\n (serialization_cost size + I.check_signature_on_algo algo size)\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 let open Result_syntax in\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 -> return_unit\n | View\n when is_in_lambda tc_context\n || legacy (* Legacy check introduced in Jakarta *) ->\n return_unit\n | View ->\n tzfail 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.t;\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.t;\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 sender : 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_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 balance_updates : Receipt.balance_updates;\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.t;\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.t;\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 sender : 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 ({sender; 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_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 {sender; 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_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 balance_updates : Receipt.balance_updates;\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 let case = function\n | Tag tag ->\n (* The tag was used by old variant. It have been removed in\n protocol proposal O, it can be unblocked in the future. *)\n let to_tx_rollup_reserved_tag = 1 in\n assert (Compare.Int.(tag <> to_tx_rollup_reserved_tag)) ;\n case (Tag tag)\n | _ as c -> case c\n in\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_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 {sender; operation; nonce}) ->\n ((sender, nonce), Internal_operation_contents operation))\n (fun ((sender, nonce), Internal_operation_contents operation) ->\n Internal_operation {sender; operation; nonce})\n (merge_objs\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/710\n Rename the \"source\" field into \"sender\" *)\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 obj2\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"balance_updates\" Receipt.balance_updates_encoding []))\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\n | IDelegation_result {consumed_gas; balance_updates} ->\n (consumed_gas, balance_updates))\n ~inj:(fun (consumed_gas, balance_updates) ->\n IDelegation_result {consumed_gas; balance_updates})\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 (* TODO: https://gitlab.com/tezos/tezos/-/issues/710\n Rename the \"source\" field into \"sender\" *)\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.sender, op.nonce), (ires_case.proj op.operation, res))\n | None -> None)\n (fun (((), sender, nonce), (op, res)) ->\n let op = {sender; 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 | Preattestation_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n consensus_power : int;\n }\n -> Kind.preattestation contents_result\n | Attestation_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n consensus_power : int;\n }\n -> Kind.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_attestation_evidence_result : {\n forbidden_delegate : Signature.public_key_hash option;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.double_attestation_evidence contents_result\n | Double_preattestation_evidence_result : {\n forbidden_delegate : Signature.public_key_hash option;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.double_preattestation_evidence contents_result\n | Double_baking_evidence_result : {\n forbidden_delegate : Signature.public_key_hash option;\n balance_updates : Receipt.balance_updates;\n }\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 balance_updates : Receipt.balance_updates;\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 | 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_commitment_result : {\n slot_header : Dal.Slot.Header.t;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.dal_publish_commitment 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 commitment_hash : Sc_rollup.Commitment.Hash.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 whitelist_update : Sc_rollup.Whitelist.update option;\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\n(** Operation metadata encoding that accepts legacy attestation name :\n `endorsement` (and preendorsement, double_<op>_evidence) in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5531\n\n This encoding is temporary and should be removed when the protocol no longer\n accepts JSON endorsements kinds\n*)\nval operation_metadata_encoding_with_legacy_attestation_name :\n 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\n(** Operation data and metadata encoding that accepts legacy attestation name :\n `endorsement` (and preendorsement, double_<op>_evidence) in JSON\n\n https://gitlab.com/tezos/tezos/-/issues/5531\n\n This encoding is temporary and should be removed when the protocol no longer\n accepts JSON endorsements kinds\n*)\nval operation_data_and_metadata_encoding_with_legacy_attestation_name :\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 contents_and_result_list_encoding_with_legacy_attestation_name :\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 : Per_block_votes.Liquidity_baking_toggle_EMA.t;\n adaptive_issuance_vote_ema : Per_block_votes.Adaptive_issuance_launch_EMA.t;\n adaptive_issuance_launch_cycle : Cycle.t option;\n implicit_operations_results : packed_successful_manager_operation_result list;\n dal_attestation : Dal.Attestation.t;\n}\n\nval block_metadata_encoding_with_legacy_attestation_name :\n block_metadata Data_encoding.encoding\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 balance_updates : Receipt.balance_updates;\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 | 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_commitment_result : {\n slot_header : Dal.Slot.Header.t;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.dal_publish_commitment 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 commitment_hash : Sc_rollup.Commitment.Hash.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 whitelist_update : Sc_rollup.Whitelist.update option;\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 let case = function\n | Tag tag ->\n (* The tag was used by old variant. It have been removed in\n protocol proposal O, it can be unblocked in the future. *)\n let to_tx_rollup_reserved_tag = 1 in\n assert (Compare.Int.(tag <> to_tx_rollup_reserved_tag)) ;\n case (Tag tag)\n | _ as c -> case c\n in\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_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 obj2\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"balance_updates\" Receipt.balance_updates_encoding []))\n ~select:(function\n | Successful_manager_result (Delegation_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Delegation_manager_kind\n ~proj:(function\n | Delegation_result {consumed_gas; balance_updates} ->\n (consumed_gas, balance_updates))\n ~inj:(fun (consumed_gas, balance_updates) ->\n Delegation_result {consumed_gas; balance_updates})\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 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_commitment_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.dal_publish_commitment_case\n ~encoding:\n (obj2\n (req \"slot_header\" Dal.Slot.Header.encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Dal_publish_commitment_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Dal_publish_commitment_result {slot_header; consumed_gas} ->\n (slot_header, consumed_gas))\n ~kind:Kind.Dal_publish_commitment_manager_kind\n ~inj:(fun (slot_header, consumed_gas) ->\n Dal_publish_commitment_result {slot_header; 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 (obj3\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"inbox_level\" Raw_level.encoding)\n (req \"commitment_hash\" Sc_rollup.Commitment.Hash.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; commitment_hash}\n ->\n (consumed_gas, inbox_level, commitment_hash))\n ~kind:Kind.Sc_rollup_cement_manager_kind\n ~inj:(fun (consumed_gas, inbox_level, commitment_hash) ->\n Sc_rollup_cement_result {consumed_gas; inbox_level; commitment_hash})\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 obj5\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (req \"ticket_updates\" Ticket_receipt.encoding)\n (opt \"whitelist_update\" Sc_rollup.Whitelist.update_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 whitelist_update;\n consumed_gas;\n paid_storage_size_diff;\n } ->\n ( balance_updates,\n ticket_receipt,\n whitelist_update,\n consumed_gas,\n paid_storage_size_diff ))\n ~inj:\n (fun ( balance_updates,\n ticket_receipt,\n whitelist_update,\n consumed_gas,\n paid_storage_size_diff ) ->\n Sc_rollup_execute_outbox_message_result\n {\n balance_updates;\n ticket_receipt;\n whitelist_update;\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 | Preattestation_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n consensus_power : int;\n }\n -> Kind.preattestation contents_result\n | Attestation_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n consensus_power : int;\n }\n -> Kind.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_attestation_evidence_result : {\n forbidden_delegate : Signature.public_key_hash option;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.double_attestation_evidence contents_result\n | Double_preattestation_evidence_result : {\n forbidden_delegate : Signature.public_key_hash option;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.double_preattestation_evidence contents_result\n | Double_baking_evidence_result : {\n forbidden_delegate : Signature.public_key_hash option;\n balance_updates : Receipt.balance_updates;\n }\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.Transfer_ticket_manager_kind, Kind.Transfer_ticket_manager_kind ->\n Some Eq\n | Kind.Transfer_ticket_manager_kind, _ -> None\n | ( Kind.Dal_publish_commitment_manager_kind,\n Kind.Dal_publish_commitment_manager_kind ) ->\n Some Eq\n | Kind.Dal_publish_commitment_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 let consensus_result_encoding power_name =\n let open Data_encoding in\n obj4\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req (Format.asprintf \"%s_power\" power_name) int31)\n (req \"consensus_key\" Signature.Public_key_hash.encoding)\n\n let consensus_result_encoding_legacy power_name =\n consensus_result_encoding power_name\n\n let consensus_result_encoding = consensus_result_encoding \"consensus\"\n\n type 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 -> 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 = consensus_result_encoding_legacy \"preendorsement\";\n select =\n (function\n | Contents_result (Preattestation_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Preattestation _ as op), res) -> Some (op, res)\n | _ -> None);\n proj =\n (function\n | Preattestation_result\n {balance_updates; delegate; consensus_key; consensus_power} ->\n (balance_updates, delegate, consensus_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, consensus_power, consensus_key) ->\n Preattestation_result\n {balance_updates; delegate; consensus_key; consensus_power});\n }\n\n let preattestation_case =\n Case\n {\n op_case = Operation.Encoding.preattestation_case;\n encoding = consensus_result_encoding;\n select =\n (function\n | Contents_result (Preattestation_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Preattestation _ as op), res) -> Some (op, res)\n | _ -> None);\n proj =\n (function\n | Preattestation_result\n {balance_updates; delegate; consensus_key; consensus_power} ->\n (balance_updates, delegate, consensus_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, consensus_power, consensus_key) ->\n Preattestation_result\n {balance_updates; delegate; consensus_key; consensus_power});\n }\n\n let endorsement_case =\n Case\n {\n op_case = Operation.Encoding.endorsement_case;\n encoding = consensus_result_encoding_legacy \"endorsement\";\n select =\n (function\n | Contents_result (Attestation_result _ as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result\n ((Attestation {dal_content = None; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n proj =\n (function\n | Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power} ->\n (balance_updates, delegate, consensus_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, consensus_power, consensus_key) ->\n Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power});\n }\n\n let attestation_case =\n Case\n {\n op_case = Operation.Encoding.attestation_case;\n encoding = consensus_result_encoding;\n select =\n (function\n | Contents_result (Attestation_result _ as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result\n ((Attestation {dal_content = None; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n proj =\n (function\n | Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power} ->\n (balance_updates, delegate, consensus_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, consensus_power, consensus_key) ->\n Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power});\n }\n\n let endorsement_with_dal_case =\n Case\n {\n op_case = Operation.Encoding.endorsement_with_dal_case;\n encoding = consensus_result_encoding_legacy \"endorsement\";\n select =\n (function\n | Contents_result (Attestation_result _ as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result\n ((Attestation {dal_content = Some _; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n proj =\n (function\n | Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power} ->\n (balance_updates, delegate, consensus_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, consensus_power, consensus_key) ->\n Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power});\n }\n\n let attestation_with_dal_case =\n Case\n {\n op_case = Operation.Encoding.attestation_with_dal_case;\n encoding = consensus_result_encoding;\n select =\n (function\n | Contents_result (Attestation_result _ as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result\n ((Attestation {dal_content = Some _; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n proj =\n (function\n | Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power} ->\n (balance_updates, delegate, consensus_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, consensus_power, consensus_key) ->\n Attestation_result\n {balance_updates; delegate; consensus_key; consensus_power});\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 obj2\n (opt \"forbidden_delegate\" Signature.Public_key_hash.encoding)\n (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_attestation_evidence_result _ as op) ->\n Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_attestation_evidence _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj =\n (fun (Double_attestation_evidence_result\n {forbidden_delegate; balance_updates}) ->\n (forbidden_delegate, balance_updates));\n inj =\n (fun (forbidden_delegate, balance_updates) ->\n Double_attestation_evidence_result\n {forbidden_delegate; balance_updates});\n }\n\n let double_attestation_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_attestation_evidence_case;\n encoding =\n obj2\n (opt \"forbidden_delegate\" Signature.Public_key_hash.encoding)\n (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_attestation_evidence_result _ as op) ->\n Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_attestation_evidence _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj =\n (fun (Double_attestation_evidence_result\n {forbidden_delegate; balance_updates}) ->\n (forbidden_delegate, balance_updates));\n inj =\n (fun (forbidden_delegate, balance_updates) ->\n Double_attestation_evidence_result\n {forbidden_delegate; balance_updates});\n }\n\n let double_preendorsement_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_preendorsement_evidence_case;\n encoding =\n obj2\n (opt \"forbidden_delegate\" Signature.Public_key_hash.encoding)\n (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_preattestation_evidence_result _ as op) ->\n Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_preattestation_evidence _ as op), res)\n ->\n Some (op, res)\n | _ -> None);\n proj =\n (fun (Double_preattestation_evidence_result\n {forbidden_delegate; balance_updates}) ->\n (forbidden_delegate, balance_updates));\n inj =\n (fun (forbidden_delegate, balance_updates) ->\n Double_preattestation_evidence_result\n {forbidden_delegate; balance_updates});\n }\n\n let double_preattestation_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_preattestation_evidence_case;\n encoding =\n obj2\n (opt \"forbidden_delegate\" Signature.Public_key_hash.encoding)\n (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_preattestation_evidence_result _ as op) ->\n Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_preattestation_evidence _ as op), res)\n ->\n Some (op, res)\n | _ -> None);\n proj =\n (fun (Double_preattestation_evidence_result\n {forbidden_delegate; balance_updates}) ->\n (forbidden_delegate, balance_updates));\n inj =\n (fun (forbidden_delegate, balance_updates) ->\n Double_preattestation_evidence_result\n {forbidden_delegate; balance_updates});\n }\n\n let double_baking_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_baking_evidence_case;\n encoding =\n obj2\n (opt \"forbidden_delegate\" Signature.Public_key_hash.encoding)\n (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 =\n (fun (Double_baking_evidence_result\n {forbidden_delegate; balance_updates}) ->\n (forbidden_delegate, balance_updates));\n inj =\n (fun (forbidden_delegate, balance_updates) ->\n Double_baking_evidence_result {forbidden_delegate; balance_updates});\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 (Preattestation_result _) -> None\n | Contents_result (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_attestation_evidence_result _) -> None\n | Contents_result (Double_preattestation_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 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_commitment_case =\n make_manager_case\n Operation.Encoding.dal_publish_commitment_case\n Manager_result.dal_publish_commitment_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Dal_publish_commitment _; _} as 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 common_cases =\n let open Encoding in\n [\n seed_nonce_revelation_case;\n vdf_revelation_case;\n double_baking_evidence_case;\n activate_account_case;\n proposals_case;\n ballot_case;\n drain_delegate_case;\n reveal_case;\n transaction_case;\n origination_case;\n delegation_case;\n register_global_constant_case;\n set_deposits_limit_case;\n increase_paid_storage_case;\n update_consensus_key_case;\n transfer_ticket_case;\n dal_publish_commitment_case;\n sc_rollup_originate_case;\n sc_rollup_add_messages_case;\n sc_rollup_cement_case;\n sc_rollup_publish_case;\n sc_rollup_refute_case;\n sc_rollup_timeout_case;\n sc_rollup_execute_outbox_message_case;\n sc_rollup_recover_bond_case;\n zk_rollup_origination_case;\n zk_rollup_publish_case;\n zk_rollup_update_case;\n ]\n\nlet contents_cases =\n let open Encoding in\n attestation_case :: attestation_with_dal_case :: preattestation_case\n :: double_attestation_evidence_case :: double_preattestation_evidence_case\n :: common_cases\n\nlet contents_cases_with_legacy_attestation_name =\n let open Encoding in\n endorsement_case :: endorsement_with_dal_case :: preendorsement_case\n :: double_endorsement_evidence_case :: double_preendorsement_evidence_case\n :: common_cases\n\nlet make_contents_result\n (Encoding.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 Encoding.tagged_case (Tag tag) name encoding proj inj\n\nlet contents_result_encoding =\n def \"operation.alpha.contents_result\"\n @@ union (List.map make_contents_result contents_cases)\n\nlet contents_result_encoding_with_legacy_attestation_name =\n def \"operation_with_legacy_attestation_name.alpha.contents_result\"\n @@ union\n (List.map\n make_contents_result\n contents_cases_with_legacy_attestation_name)\n\nlet make_contents_and_result\n (Encoding.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 Encoding.tagged_case (Tag tag) name encoding proj inj\n\nlet contents_and_result_encoding =\n def \"operation.alpha.operation_contents_and_result\"\n @@ union (List.map make_contents_and_result contents_cases)\n\nlet contents_and_result_encoding_with_legacy_attestation_name =\n def\n \"operation_with_legacy_attestation_name.alpha.operation_contents_and_result\"\n @@ union\n (List.map\n make_contents_and_result\n contents_cases_with_legacy_attestation_name)\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_conv_with_guard =\n let open Result_syntax in\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 let* (Contents_result_list os) = of_list os in\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 conv_with_guard to_list of_list\n\nlet contents_result_list_encoding =\n def \"operation.alpha.contents_list_result\"\n @@ contents_result_list_conv_with_guard (list contents_result_encoding)\n\nlet contents_result_list_encoding_with_legacy_attestation_name =\n def \"operation_with_legacy_attestation_name.alpha.contents_list_result\"\n @@ contents_result_list_conv_with_guard\n (list contents_result_encoding_with_legacy_attestation_name)\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_conv_with_guard =\n let open Result_syntax in\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 let* (Contents_and_result_list rest) = of_list rest in\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\n\nlet contents_and_result_list_encoding =\n contents_and_result_conv_with_guard\n (Variable.list contents_and_result_encoding)\n\nlet contents_and_result_list_encoding_with_legacy_attestation_name =\n contents_and_result_conv_with_guard\n (Variable.list contents_and_result_encoding_with_legacy_attestation_name)\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 operation_metadata_encoding_with_legacy_attestation_name =\n def \"operation_with_legacy_attestation_name.alpha.result\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Operation_metadata\"\n contents_result_list_encoding_with_legacy_attestation_name\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 | Attestation _, Attestation_result _ -> Some Eq\n | Attestation _, _ -> None\n | Preattestation _, Preattestation_result _ -> Some Eq\n | Preattestation _, _ -> 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_preattestation_evidence _, Double_preattestation_evidence_result _ ->\n Some Eq\n | Double_preattestation_evidence _, _ -> None\n | Double_attestation_evidence _, Double_attestation_evidence_result _ ->\n Some Eq\n | Double_attestation_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 = 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 = 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_commitment _; _},\n Manager_operation_result\n {operation_result = Applied (Dal_publish_commitment_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Dal_publish_commitment _; _},\n Manager_operation_result\n {operation_result = Backtracked (Dal_publish_commitment_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Dal_publish_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Dal_publish_commitment_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Dal_publish_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Dal_publish_commitment_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Dal_publish_commitment _; _}, _ -> 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\nlet operation_data_and_metadata_encoding_with_legacy_attestation_name =\n def \"operation_with_legacy_attestation_name.alpha.operation_with_metadata\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Operation_with_metadata\"\n (obj2\n (req\n \"contents\"\n (dynamic_size\n contents_and_result_list_encoding_with_legacy_attestation_name))\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\n \"contents\"\n (dynamic_size\n Operation\n .contents_list_encoding_with_legacy_attestation_name))\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 : Per_block_votes.Liquidity_baking_toggle_EMA.t;\n adaptive_issuance_vote_ema : Per_block_votes.Adaptive_issuance_launch_EMA.t;\n adaptive_issuance_launch_cycle : Cycle.t option;\n implicit_operations_results : packed_successful_manager_operation_result list;\n dal_attestation : Dal.Attestation.t;\n}\n\nlet block_metadata_encoding ~use_legacy_attestation_name =\n let open Data_encoding in\n def\n (if use_legacy_attestation_name then\n \"block_header.alpha.metadata_with_legacy_attestation_name\"\n else \"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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\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 adaptive_issuance_vote_ema,\n adaptive_issuance_launch_cycle ),\n ( implicit_operations_results,\n proposer_active_key,\n baker_active_key,\n consumed_gas,\n dal_attestation ) ))\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 adaptive_issuance_vote_ema,\n adaptive_issuance_launch_cycle ),\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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\n implicit_operations_results;\n dal_attestation;\n })\n (merge_objs\n (obj10\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\n \"balance_updates\"\n (if use_legacy_attestation_name then\n Receipt.balance_updates_encoding_with_legacy_attestation_name\n else Receipt.balance_updates_encoding)\n [])\n (req\n \"liquidity_baking_toggle_ema\"\n Per_block_votes.Liquidity_baking_toggle_EMA.encoding)\n (req\n \"adaptive_issuance_vote_ema\"\n Per_block_votes.Adaptive_issuance_launch_EMA.encoding)\n (opt \"adaptive_issuance_activation_cycle\" Cycle.encoding))\n (obj5\n (req\n \"implicit_operations_results\"\n (list successful_manager_operation_result_encoding))\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 (req \"dal_attestation\" Dal.Attestation.encoding)))\n\nlet block_metadata_encoding_with_legacy_attestation_name =\n block_metadata_encoding ~use_legacy_attestation_name:true\n\nlet block_metadata_encoding =\n block_metadata_encoding ~use_legacy_attestation_name:false\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\n {!Script_ir_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_tickets:bool ->\n allow_forged_lazy_storage_id: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 | 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 | Or_t (utl, utr, _meta, _) ->\n let entrypoints_l, entrypoints_r =\n match nested_entrypoints with\n | Entrypoints_None -> (no_entrypoints, no_entrypoints)\n | Entrypoints_Or {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 let open Result_syntax in\n let+ ctxt = Gas.consume ctxt (Unparse_costs.unparse_type ty) in\n (unparse_ty_uncarbonated ~loc ty, ctxt)\n\nlet unparse_parameter_ty ~loc ctxt ty ~entrypoints =\n let open Result_syntax in\n let+ ctxt = Gas.consume ctxt (Unparse_costs.unparse_type ty) in\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 let open Result_syntax in\n match mode with\n | Optimized | Optimized_legacy ->\n return (Int (loc, Script_timestamp.to_zint t), ctxt)\n | Readable -> (\n let* ctxt = Gas.consume ctxt Unparse_costs.timestamp_readable in\n match Script_timestamp.to_notation t with\n | None -> return (Int (loc, Script_timestamp.to_zint t), ctxt)\n | Some s -> return (String (loc, s), ctxt))\n\nlet unparse_address ~loc ctxt mode {destination; entrypoint} =\n let open Result_syntax in\n match mode with\n | Optimized | Optimized_legacy ->\n let+ ctxt = Gas.consume ctxt Unparse_costs.contract_optimized in\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 let+ ctxt = Gas.consume ctxt Unparse_costs.contract_readable in\n let notation =\n Destination.to_b58check destination\n ^ Entrypoint.to_address_suffix entrypoint\n in\n (String (loc, notation), 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 open Result_syntax in\n let s = Script_signature.get s in\n match mode with\n | Optimized | Optimized_legacy ->\n let+ ctxt = Gas.consume ctxt Unparse_costs.signature_optimized in\n let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n let+ ctxt = Gas.consume ctxt Unparse_costs.signature_readable in\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 let open Result_syntax in\n match mode with\n | Optimized | Optimized_legacy ->\n let+ ctxt = Gas.consume ctxt Unparse_costs.public_key_optimized in\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 let+ ctxt = Gas.consume ctxt Unparse_costs.public_key_readable in\n (String (loc, Signature.Public_key.to_b58check k), ctxt)\n\nlet unparse_key_hash ~loc ctxt mode k =\n let open Result_syntax in\n match mode with\n | Optimized | Optimized_legacy ->\n let+ ctxt = Gas.consume ctxt Unparse_costs.key_hash_optimized in\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 let+ ctxt = Gas.consume ctxt Unparse_costs.key_hash_readable in\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 open Result_syntax in\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 let+ ctxt = Gas.consume ctxt (Unparse_costs.operation bytes) in\n (Bytes (loc, bytes), ctxt)\n\nlet unparse_chain_id ~loc ctxt mode chain_id =\n let open Result_syntax in\n match mode with\n | Optimized | Optimized_legacy ->\n let+ ctxt = Gas.consume ctxt Unparse_costs.chain_id_optimized in\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 let+ ctxt = Gas.consume ctxt Unparse_costs.chain_id_readable in\n (String (loc, Script_chain_id.to_b58check chain_id), ctxt)\n\nlet unparse_bls12_381_g1 ~loc ctxt x =\n let open Result_syntax in\n let+ ctxt = Gas.consume ctxt Unparse_costs.bls12_381_g1 in\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 let open Result_syntax in\n let+ ctxt = Gas.consume ctxt Unparse_costs.bls12_381_g2 in\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 let open Result_syntax in\n let+ ctxt = Gas.consume ctxt Unparse_costs.bls12_381_fr in\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 let open Lwt_result_syntax in\n let*? ctxt = Gas.consume ctxt unparse_cost in\n let bytes = Data_encoding.Binary.to_bytes_exn encoding s in\n return (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 let open Lwt_result_syntax in\n let* l, ctxt = unparse_l ctxt l in\n let+ r, ctxt = unparse_r ctxt r in\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_or ~loc unparse_l unparse_r ctxt =\n let open Lwt_result_syntax in\n function\n | L l ->\n let+ l, ctxt = unparse_l ctxt l in\n (Prim (loc, D_Left, [l], []), ctxt)\n | R r ->\n let+ r, ctxt = unparse_r ctxt r in\n (Prim (loc, D_Right, [r], []), ctxt)\n\nlet unparse_option ~loc unparse_v ctxt =\n let open Lwt_result_syntax in\n function\n | Some v ->\n let+ v, ctxt = unparse_v ctxt v in\n (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 let open Lwt_result_syntax in\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 let*? ctxt =\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 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 | 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 =\n unparse_comparable_data_rec ~loc ctxt mode tl v\n in\n let unparse_r ctxt v =\n unparse_comparable_data_rec ~loc ctxt mode tr v\n in\n unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair\n | Or_t (tl, tr, _, YesYes), v ->\n let unparse_l ctxt v =\n unparse_comparable_data_rec ~loc ctxt mode tl v\n in\n let unparse_r ctxt v =\n unparse_comparable_data_rec ~loc ctxt mode tr v\n in\n unparse_or ~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 let open Result_syntax in\n let* ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed_data) in\n let unparsed_data = Micheline.strip_locations unparsed_data in\n let+ ctxt =\n Gas.consume ctxt (Script.micheline_serialization_cost unparsed_data)\n in\n (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_tickets:bool ->\n allow_forged_lazy_storage_id: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 let open Lwt_result_syntax in\n fun ctxt ~stack_depth mode ty a ->\n let*? ctxt = Gas.consume ctxt Unparse_costs.unparse_data_cycle in\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 ->\n Lwt.return @@ unparse_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 | Or_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_or ~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 let+ items, ctxt =\n List.fold_left_es\n (fun (l, ctxt) element ->\n let+ unparsed, ctxt =\n non_terminal_recursion ctxt mode t element\n in\n (unparsed :: l, ctxt))\n ([], ctxt)\n items.elements\n in\n (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 let*? t = P.opened_ticket_type loc t in\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 let+ items, ctxt =\n List.fold_left_es\n (fun (l, ctxt) item ->\n let+ item, ctxt =\n unparse_comparable_data_rec ~loc ctxt mode t item\n in\n (item :: l, ctxt))\n ([], ctxt)\n (Script_set.fold (fun e acc -> e :: acc) set [])\n in\n (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 let+ items, ctxt =\n unparse_items_rec\n ctxt\n ~stack_depth:(stack_depth + 1)\n mode\n kt\n vt\n items\n in\n (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 let*? vt = option_t loc vt in\n let+ items, ctxt =\n unparse_items_rec\n ctxt\n ~stack_depth:(stack_depth + 1)\n mode\n kt\n vt\n items\n in\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 let+ items, ctxt =\n unparse_items_rec\n ctxt\n ~stack_depth:(stack_depth + 1)\n mode\n kt\n vt\n items\n in\n (Micheline.Seq (loc, items), ctxt)\n | Lambda_t _, Lam (_, original_code) ->\n unparse_code_rec\n ctxt\n ~stack_depth:(stack_depth + 1)\n mode\n original_code\n | Lambda_t _, LamRec (_, original_code) ->\n let+ body, ctxt =\n unparse_code_rec\n ctxt\n ~stack_depth:(stack_depth + 1)\n mode\n original_code\n in\n (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt)\n | Never_t, _ -> .\n | Sapling_transaction_t _, s ->\n let*? ctxt = Gas.consume ctxt (Unparse_costs.sapling_transaction s) in\n let bytes =\n Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s\n in\n return (Bytes (loc, bytes), ctxt)\n | Sapling_transaction_deprecated_t _, s ->\n let*? ctxt =\n Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s)\n in\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Sapling.Legacy.transaction_encoding\n s\n in\n return (Bytes (loc, bytes), ctxt)\n | Sapling_state_t _, {id; diff; _} ->\n let*? ctxt = Gas.consume ctxt (Unparse_costs.sapling_diff diff) in\n return\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 let open Lwt_result_syntax in\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 let* key, ctxt = unparse_comparable_data_rec ~loc ctxt mode kt k in\n let+ value, ctxt =\n unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode vt v\n in\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 open Lwt_result_syntax in\n let elab_conf = Script_ir_translator_config.make ~legacy:true () in\n let*? ctxt = Gas.consume ctxt Unparse_costs.unparse_instr_cycle in\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 let*? Ex_ty t, ctxt =\n P.parse_packable_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:elab_conf.legacy\n ty\n in\n let allow_forged_tickets, allow_forged_lazy_storage_id =\n (false, 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 let* data, ctxt =\n P.parse_data\n ~unparse_code_rec\n ~elab_conf\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~allow_forged_tickets\n ~allow_forged_lazy_storage_id\n t\n data\n in\n let* data, ctxt =\n unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode t data\n in\n return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)\n | Seq (loc, items) ->\n let* items, ctxt =\n List.fold_left_es\n (fun (l, ctxt) item ->\n let+ item, ctxt = non_terminal_recursion ctxt mode item in\n (item :: l, ctxt))\n ([], ctxt)\n items\n in\n return (Micheline.Seq (loc, List.rev items), ctxt)\n | Prim (loc, prim, items, annot) ->\n let* items, ctxt =\n List.fold_left_es\n (fun (l, ctxt) item ->\n let+ item, ctxt = non_terminal_recursion ctxt mode item in\n (item :: l, ctxt))\n ([], ctxt)\n items\n in\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 let open Lwt_result_syntax in\n let* unparsed_data, ctxt = unparse_data_rec ctxt ~stack_depth mode ty v in\n Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)\n\n let unparse_code ctxt ~stack_depth mode v =\n let open Lwt_result_syntax in\n let* unparsed_data, ctxt = unparse_code_rec ctxt ~stack_depth mode v in\n Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)\n\n let unparse_items ctxt ~stack_depth mode ty vty vs =\n let open Lwt_result_syntax in\n let* unparsed_datas, ctxt =\n unparse_items_rec ctxt ~stack_depth mode ty vty vs\n in\n let*? unparsed_datas, ctxt =\n List.fold_left_e\n (fun (acc, ctxt) unparsed_data ->\n let open Result_syntax in\n let+ unparsed_data, ctxt =\n account_for_future_serialization_cost unparsed_data ctxt\n in\n (unparsed_data :: acc, ctxt))\n ([], ctxt)\n unparsed_datas\n in\n 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 let open Lwt_result_syntax in\n let* unparsed_data, ctxt =\n unparse_comparable_data_rec ctxt ~loc:() mode ty v\n in\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\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_tickets:bool ->\n allow_forged_lazy_storage_id: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 -> 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_tickets:bool ->\n allow_forged_lazy_storage_id: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_tickets_in_storage:bool ->\n allow_forged_lazy_storage_id_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_tickets_in_storage:bool ->\n allow_forged_lazy_storage_id_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(* Copyright (c) 2024 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\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 open Result_syntax in\n let kind = kind expr in\n if List.exists (kind_equal kind) kinds then return_unit\n else\n let loc = location expr in\n tzfail (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 let open Result_syntax in\n fun loc ty ->\n match is_comparable ty with\n | Yes -> return Eq\n | No ->\n let t = Script_ir_unparser.serialize_ty_for_error ty in\n tzfail (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 let open Lwt_result_syntax in\n let+ unparsed, ctxt = unparse_comparable_data ctxt Optimized_legacy ty data in\n pack_node unparsed ctxt\n\nlet hash_bytes ctxt bytes =\n let open Result_syntax in\n let+ ctxt =\n Gas.consume ctxt (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes)\n in\n (Script_expr_hash.(hash_bytes [bytes]), ctxt)\n\nlet hash_comparable_data ctxt ty data =\n let open Lwt_result_syntax in\n let* bytes, ctxt = pack_comparable_data ctxt ty data in\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 | Pair_t _ | Or_t _ | Option_t _ ->\n ()\n\nlet check_dupable_ty ctxt loc ty =\n let open Result_syntax in\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 | 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 | Or_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 let* res, ctxt = Gas_monad.run ctxt gas in\n match res with Ok () -> return ctxt | Error e -> tzfail 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_syntax.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 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 let open Result_syntax in\n fun ~(error_details : (_, error_trace) error_details) ty1 ty2 ->\n let record_trace_eval :\n type a.\n (Script.location -> error) ->\n (a, error_trace) result ->\n (a, error_trace) result =\n match error_details with\n | Fast -> fun _f m -> m\n | Informative loc -> fun f m -> record_trace_eval (fun () -> f loc) m\n in\n let type_metadata_eq meta1 meta2 =\n type_metadata_eq ~error_details meta1 meta2\n |> record_trace_eval (fun loc -> default_ty_eq_error loc ty1 ty2)\n in\n let memo_size_eq ms1 ms2 = memo_size_eq ~error_details ms1 ms2 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) result =\n fun ty1 ty2 ->\n help0 ty1 ty2\n |> record_trace_eval (fun loc -> 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) result =\n fun ty1 ty2 ->\n let not_equal () =\n Error\n (match error_details with\n | Fast -> (Inconsistent_types_fast : error_trace)\n | Informative loc -> 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 | 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 = help 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 = help 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 = help 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 = help 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 | Or_t (tal, tar, meta1, cmp1), Or_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 | Or_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,\n Sapling_transaction_deprecated_t ms2 ) ->\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 let open Gas_monad.Syntax in\n let* () = Gas_monad.consume_gas (Typecheck_costs.ty_eq ty1 ty2) in\n Gas_monad.of_result @@ 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 let open Result_syntax in\n fun loc ctxt lvl stack1 stack2 ->\n match (stack1, stack2) with\n | Bot_t, Bot_t -> return (Eq, ctxt)\n | Item_t (ty1, rest1), Item_t (ty2, rest2) ->\n let* eq, ctxt =\n Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) ty1 ty2\n |> record_trace (Bad_stack_item lvl)\n in\n let* Eq = eq in\n let+ Eq, ctxt = stack_eq loc ctxt (lvl + 1) rest1 rest2 in\n ((Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq), ctxt)\n | _, _ -> tzfail 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 let open Result_syntax in\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 (let+ Eq, ctxt = stack_eq loc ctxt 1 aftbt aftbf in\n (Typed (branch dbt dbf), ctxt))\n | Failed {descr = descrt}, Failed {descr = descrf} ->\n let descr ret = branch (descrt ret) (descrf ret) in\n return (Failed {descr}, ctxt)\n | Typed dbt, Failed {descr = descrf} ->\n return (Typed (branch dbt (descrf dbt.aft)), ctxt)\n | Failed {descr = descrt}, Typed dbf ->\n return (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 Result_syntax.tzfail\n @@ Invalid_syntactic_constant (location n, strip_locations n, msg))\n | _ -> Result_syntax.tzfail @@ 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 let open Result_syntax in\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 let* ctxt = Gas.consume ctxt Typecheck_costs.parse_type_cycle in\n if Compare.Int.(stack_depth > 10000) then\n tzfail Typechecking_too_many_recursive_calls\n else\n let* node, name =\n match ret with\n | Don't_parse_entrypoints -> return (node, (() : name))\n | Parse_entrypoints -> extract_entrypoint_annot node\n in\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 let+ () = check_type_annot loc annot in\n return ctxt unit_t\n | Prim (loc, T_int, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt int_t\n | Prim (loc, T_nat, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt nat_t\n | Prim (loc, T_string, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt string_t\n | Prim (loc, T_bytes, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt bytes_t\n | Prim (loc, T_mutez, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt mutez_t\n | Prim (loc, T_bool, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt bool_t\n | Prim (loc, T_key, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt key_t\n | Prim (loc, T_key_hash, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt key_hash_t\n | Prim (loc, T_chest_key, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt chest_key_t\n | Prim (loc, T_chest, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt chest_t\n | Prim (loc, T_timestamp, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt timestamp_t\n | Prim (loc, T_address, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt address_t\n | Prim (loc, T_signature, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt signature_t\n | Prim (loc, T_operation, [], annot) ->\n if allow_operation then\n let+ () = check_type_annot loc annot in\n return ctxt operation_t\n else tzfail (Unexpected_operation loc)\n | Prim (loc, T_chain_id, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt chain_id_t\n | Prim (loc, T_never, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt never_t\n | Prim (loc, T_bls12_381_g1, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt bls12_381_g1_t\n | Prim (loc, T_bls12_381_g2, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt bls12_381_g2_t\n | Prim (loc, T_bls12_381_fr, [], annot) ->\n let+ () = check_type_annot loc annot in\n return ctxt bls12_381_fr_t\n | Prim (loc, T_contract, [utl], annot) ->\n if allow_contract then\n let* () = check_type_annot loc annot in\n let* Ex_ty tl, ctxt =\n parse_passable_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n utl\n ~ret:Don't_parse_entrypoints\n in\n let+ ty = contract_t loc tl in\n return ctxt ty\n else tzfail (Unexpected_contract loc)\n | Prim (loc, T_pair, utl :: utr, annot) ->\n let* () = check_type_annot loc annot in\n let* utl = remove_field_annot utl in\n let* Ex_ty tl, 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 utl\n in\n let* utr =\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 in\n let* Ex_ty tr, 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 in\n let+ (Ty_ex_c ty) = pair_t loc tl tr in\n return ctxt ty\n | Prim (loc, T_or, [utl; utr], annot) -> (\n let* () = check_type_annot loc annot in\n let* utl, utr =\n match ret with\n | Don't_parse_entrypoints ->\n let* utl = remove_field_annot utl in\n let+ utr = remove_field_annot utr in\n (utl, utr)\n | Parse_entrypoints -> Ok (utl, utr)\n in\n let* 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 utl\n in\n let* parsed_r, 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 in\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 let+ (Ty_ex_c ty) = or_t loc tl tr in\n ((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 let+ (Ty_ex_c arg_type) = or_t loc tl tr in\n let entrypoints =\n let at_node =\n Option.map\n (fun name -> {name; original_type_expr = node})\n name\n in\n {at_node; nested = Entrypoints_Or {left; right}}\n in\n ( Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints},\n ctxt ))\n | Prim (loc, T_lambda, [uta; utr], annot) ->\n let* () = check_type_annot loc annot in\n let* Ex_ty ta, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta\n in\n let* Ex_ty tr, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr\n in\n let+ ty = lambda_t loc ta tr in\n return ctxt ty\n | Prim (loc, T_option, [ut], annot) ->\n let* () = check_type_annot loc annot in\n let* Ex_ty t, 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 ut\n in\n let+ ty = option_t loc t in\n return ctxt ty\n | Prim (loc, T_list, [ut], annot) ->\n let* () = check_type_annot loc annot in\n let* Ex_ty t, 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 ut\n in\n let+ ty = list_t loc t in\n return ctxt ty\n | Prim (loc, T_ticket, [ut], annot) ->\n if allow_ticket then\n let* () = check_type_annot loc annot in\n let* Ex_comparable_ty t, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut\n in\n let+ ty = ticket_t loc t in\n return ctxt ty\n else tzfail (Unexpected_ticket loc)\n | Prim (loc, T_set, [ut], annot) ->\n let* () = check_type_annot loc annot in\n let* Ex_comparable_ty t, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut\n in\n let+ ty = set_t loc t in\n return ctxt ty\n | Prim (loc, T_map, [uta; utr], annot) ->\n let* () = check_type_annot loc annot in\n let* Ex_comparable_ty ta, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta\n in\n let* Ex_ty tr, 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 in\n let+ ty = map_t loc ta tr in\n return ctxt ty\n | Prim (loc, T_sapling_transaction, [memo_size], annot) ->\n let* () = check_type_annot loc annot in\n let+ memo_size = parse_memo_size memo_size in\n return ctxt (sapling_transaction_t ~memo_size)\n | Prim (loc, T_sapling_transaction_deprecated, [memo_size], annot) ->\n if legacy (* Legacy check introduced in Jakarta. *) then\n let* () = check_type_annot loc annot in\n let+ memo_size = parse_memo_size memo_size in\n return ctxt (sapling_transaction_deprecated_t ~memo_size)\n else tzfail (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 let+ Ex_ty ty, ctxt =\n parse_big_map_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n loc\n args\n annot\n in\n return ctxt ty\n | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage\n ->\n let* () = check_type_annot loc annot in\n let+ memo_size = parse_memo_size memo_size in\n return ctxt (sapling_state_t ~memo_size)\n | Prim (loc, (T_big_map | T_sapling_state), _, _) ->\n tzfail (Unexpected_lazy_storage loc)\n | Prim\n ( loc,\n (( T_unit | T_signature | T_int | T_nat | T_string | T_bytes\n | T_mutez | T_bool | T_key | T_key_hash | T_timestamp | T_address\n | T_chain_id | T_operation | T_never ) as prim),\n l,\n _ ) ->\n tzfail (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 tzfail (Invalid_arity (loc, prim, 1, List.length l))\n | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->\n tzfail (Invalid_arity (loc, prim, 2, List.length l))\n | Prim (_, T_tx_rollup_l2_address, _, _) ->\n tzfail @@ Deprecated_instruction T_tx_rollup_l2_address\n | expr ->\n tzfail\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_unit;\n ]\n\nand parse_comparable_ty :\n context ->\n stack_depth:int ->\n Script.node ->\n (ex_comparable_ty * context) tzresult =\n let open Result_syntax in\n fun ctxt ~stack_depth node ->\n let* Ex_ty t, ctxt =\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 in\n match is_comparable t with\n | Yes -> return (Ex_comparable_ty t, ctxt)\n | No ->\n tzfail\n (Comparable_type_expected\n (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 let open Result_syntax in\n let* ctxt = Gas.consume ctxt Typecheck_costs.parse_type_cycle in\n match args with\n | [key_ty; value_ty] ->\n let* () = check_type_annot big_map_loc map_annot in\n let* Ex_comparable_ty key_ty, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty\n in\n let* Ex_ty value_ty, ctxt =\n parse_big_map_value_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n value_ty\n in\n let+ big_map_ty = big_map_t big_map_loc key_ty value_ty in\n (Ex_ty big_map_ty, ctxt)\n | args -> tzfail @@ 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:false\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:false\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_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:false\n ~allow_ticket:true\n ~ret:Don't_parse_entrypoints\n node\n\n(* check_packable: determine if a `ty` is packable into Michelson *)\nlet check_packable ~allow_contract loc root =\n let open Result_syntax in\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 _ -> tzfail (Unexpected_lazy_storage loc)\n | Sapling_state_t _ -> tzfail (Unexpected_lazy_storage loc)\n | Operation_t -> tzfail (Unexpected_operation loc)\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 | Bool_t -> return_unit\n | Chain_id_t -> return_unit\n | Never_t -> return_unit\n | Set_t (_, _) -> return_unit\n | Ticket_t _ -> tzfail (Unexpected_ticket loc)\n | Lambda_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 | Pair_t (l_ty, r_ty, _, _) ->\n let* () = check l_ty in\n check r_ty\n | Or_t (l_ty, r_ty, _, _) ->\n let* () = check l_ty in\n 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 allow_contract -> return_unit\n | Contract_t (_, _) -> tzfail (Unexpected_contract loc)\n | Sapling_transaction_t _ -> return_unit\n | Sapling_transaction_deprecated_t _ -> return_unit\n | Chest_key_t -> return_unit\n | Chest_t -> 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 let open Result_syntax in\n fun ctxt stack_ty loc n value_ty ty ->\n match (n, ty) with\n | 0, _ -> return (Comb_set_proof_argument (Comb_set_zero, value_ty))\n | 1, Pair_t (_hd_ty, tl_ty, _, _) ->\n let+ (Ty_ex_c after_ty) = pair_t loc value_ty tl_ty in\n Comb_set_proof_argument (Comb_set_one, after_ty)\n | n, Pair_t (hd_ty, tl_ty, _, _) ->\n let* (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) =\n make_comb_set_proof_argument ctxt stack_ty loc (n - 2) value_ty tl_ty\n in\n let+ (Ty_ex_c after_ty) = pair_t loc hd_ty tl_ty' in\n Comb_set_proof_argument\n (Comb_set_plus_two comb_set_left_witness, after_ty)\n | _ ->\n let whole_stack = serialize_stack_for_error ctxt stack_ty in\n tzfail (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 | Or_t (tl, tr, _, _), {nested = Entrypoints_Or {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 open Result_syntax in\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 return\n ( (if reachable then acc\n else\n match ty with\n | Or_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 tzfail (Duplicate_entrypoint name)\n else return ((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 | Or_t (tl, tr, _, _), {nested = Entrypoints_Or {left; right}; _} ->\n let* acc, l_reachable = merge (D_Left :: path) tl left reachable acc in\n let* acc, r_reachable =\n merge (D_Right :: path) tr right reachable acc\n in\n let* acc = check tl left (D_Left :: path) l_reachable acc in\n check tr right (D_Right :: path) r_reachable acc\n | _ -> return 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 let* first_unreachable, all =\n check full entrypoints [] reachable (None, init)\n in\n if not (Entrypoint.Set.mem Entrypoint.default all) then return_unit\n else\n match first_unreachable with\n | None -> return_unit\n | Some path -> tzfail (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 let open Result_syntax in\n fun ctxt ~stack_depth ~legacy node ->\n let* Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt =\n parse_passable_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n node\n ~ret:Parse_entrypoints\n in\n let+ () =\n if legacy (* Legacy check introduced before Ithaca. *) then return_unit\n else well_formed_entrypoints arg_type entrypoints\n in\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 let open Result_syntax in\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 return (Z.to_int n)\n | node ->\n tzfail\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 =\n let open Result_syntax in\n function\n | Prim (loc, D_Unit, [], annot) ->\n let* () =\n if legacy (* Legacy check introduced before Ithaca. *) then return_unit\n else error_unexpected_annot loc annot\n in\n let+ ctxt = Gas.consume ctxt Typecheck_costs.unit in\n ((), ctxt)\n | Prim (loc, D_Unit, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Unit, 0, List.length l)\n | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Unit]\n\nlet parse_bool ctxt ~legacy =\n let open Result_syntax in\n function\n | Prim (loc, D_True, [], annot) ->\n let* () =\n if legacy (* Legacy check introduced before Ithaca. *) then return_unit\n else error_unexpected_annot loc annot\n in\n let+ ctxt = Gas.consume ctxt Typecheck_costs.bool in\n (true, ctxt)\n | Prim (loc, D_False, [], annot) ->\n let* () =\n if legacy (* Legacy check introduced before Ithaca. *) then return_unit\n else error_unexpected_annot loc annot\n in\n let+ ctxt = Gas.consume ctxt Typecheck_costs.bool in\n (false, ctxt)\n | Prim (loc, ((D_True | D_False) as c), l, _) ->\n tzfail @@ Invalid_arity (loc, c, 0, List.length l)\n | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_True; D_False]\n\nlet parse_string ctxt : Script.node -> (Script_string.t * context) tzresult =\n let open Result_syntax in\n function\n | String (loc, v) as expr ->\n let* ctxt = Gas.consume ctxt (Typecheck_costs.check_printable v) in\n record_trace\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a printable ascii string\"))\n (let+ s = Script_string.of_string v in\n (s, ctxt))\n | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr)\n\nlet parse_bytes ctxt =\n let open Result_syntax in\n function\n | Bytes (_, v) -> return (v, ctxt)\n | expr -> tzfail @@ Invalid_kind (location expr, [Bytes_kind], kind expr)\n\nlet parse_int ctxt =\n let open Result_syntax in\n function\n | Int (_, v) -> return (Script_int.of_zint v, ctxt)\n | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr)\n\nlet parse_nat ctxt :\n Script.node -> (Script_int.n Script_int.num * context) tzresult =\n let open Result_syntax in\n 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 -> return (nat, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a non-negative integer\"))\n | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr)\n\nlet parse_mutez ctxt : Script.node -> (Tez.t * context) tzresult =\n let open Result_syntax in\n 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 tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid mutez amount\"))\n | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr)\n\nlet parse_timestamp ctxt :\n Script.node -> (Script_timestamp.t * context) tzresult =\n let open Result_syntax in\n function\n | Int (_, v) (* As unparsed with [Optimized] or out of bounds [Readable]. *)\n ->\n return (Script_timestamp.of_zint v, ctxt)\n | String (loc, s) as expr (* As unparsed with [Readable]. *) -> (\n let* ctxt = Gas.consume ctxt (Typecheck_costs.timestamp_readable s) in\n match Script_timestamp.of_string s with\n | Some v -> return (v, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid timestamp\"))\n | expr ->\n tzfail @@ Invalid_kind (location expr, [String_kind; Int_kind], kind expr)\n\nlet parse_key ctxt : Script.node -> (public_key * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\n (* As unparsed with [Optimized]. *)\n let* ctxt = Gas.consume ctxt Typecheck_costs.public_key_optimized in\n match\n Data_encoding.Binary.of_bytes_opt Signature.Public_key.encoding bytes\n with\n | Some k -> return (k, ctxt)\n | None ->\n tzfail\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 let* ctxt = Gas.consume ctxt Typecheck_costs.public_key_readable in\n match Signature.Public_key.of_b58check_opt s with\n | Some k -> return (k, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid public key\"))\n | expr ->\n tzfail\n @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_key_hash ctxt : Script.node -> (public_key_hash * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\n (* As unparsed with [Optimized]. *)\n let* ctxt = Gas.consume ctxt Typecheck_costs.key_hash_optimized in\n match\n Data_encoding.Binary.of_bytes_opt\n Signature.Public_key_hash.encoding\n bytes\n with\n | Some k -> return (k, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid key hash\"))\n | String (loc, s) as expr (* As unparsed with [Readable]. *) -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.key_hash_readable in\n match Signature.Public_key_hash.of_b58check_opt s with\n | Some k -> return (k, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid key hash\"))\n | expr ->\n tzfail\n @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_signature ctxt : Script.node -> (signature * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.signature_optimized in\n match\n Data_encoding.Binary.of_bytes_opt Script_signature.encoding bytes\n with\n | Some k -> return (k, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid signature\"))\n | String (loc, s) as expr (* As unparsed with [Readable]. *) -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.signature_readable in\n match Script_signature.of_b58check_opt s with\n | Some s -> return (s, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid signature\"))\n | expr ->\n tzfail\n @@ 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 =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.chain_id_optimized in\n match\n Data_encoding.Binary.of_bytes_opt Script_chain_id.encoding bytes\n with\n | Some k -> return (k, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid chain id\"))\n | String (loc, s) as expr -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.chain_id_readable in\n match Script_chain_id.of_b58check_opt s with\n | Some s -> return (s, ctxt)\n | None ->\n tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid chain id\"))\n | expr ->\n tzfail\n @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_address ctxt : Script.node -> (address * context) tzresult =\n let open Result_syntax in\n let destination_allowed loc {destination; entrypoint} ctxt =\n match destination with\n | Destination.Zk_rollup _ when not (Constants.zk_rollup_enable ctxt) ->\n tzfail @@ Zk_rollup_disabled loc\n | _ -> Ok ({destination; entrypoint}, ctxt)\n in\n function\n | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.contract_optimized in\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 tzfail\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid address\"))\n | String (loc, s) (* As unparsed with [Readable]. *) ->\n let* ctxt = Gas.consume ctxt Typecheck_costs.contract_readable in\n let* addr, entrypoint =\n match String.index_opt s '%' with\n | None -> return (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 let+ entrypoint = Entrypoint.of_string_strict ~loc name in\n (String.sub s 0 pos, entrypoint)\n in\n let* destination = Destination.of_b58check addr in\n destination_allowed loc {destination; entrypoint} ctxt\n | expr ->\n tzfail\n @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_never expr : (never * context) tzresult =\n Result_syntax.tzfail @@ Invalid_never_expr (location expr)\n\nlet parse_bls12_381_g1 ctxt :\n Script.node -> (Script_bls.G1.t * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bs) as expr -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in\n match Script_bls.G1.of_bytes_opt bs with\n | Some pt -> return (pt, ctxt)\n | None ->\n tzfail\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid BLS12-381 G1 element\")))\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nlet parse_bls12_381_g2 ctxt :\n Script.node -> (Script_bls.G2.t * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bs) as expr -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in\n match Script_bls.G2.of_bytes_opt bs with\n | Some pt -> return (pt, ctxt)\n | None ->\n tzfail\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid BLS12-381 G2 element\")))\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nlet parse_bls12_381_fr ctxt :\n Script.node -> (Script_bls.Fr.t * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bs) as expr -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in\n match Script_bls.Fr.of_bytes_opt bs with\n | Some pt -> return (pt, ctxt)\n | None ->\n tzfail\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid BLS12-381 field element\")))\n | Int (_, v) ->\n let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in\n return (Script_bls.Fr.of_z v, ctxt)\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nlet parse_sapling_transaction ctxt ~memo_size :\n Script.node -> (Sapling.transaction * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\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 let* () =\n memo_size_eq\n ~error_details:(Informative ())\n memo_size\n transac_memo_size\n in\n return (transaction, ctxt))\n | None ->\n tzfail\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid Sapling transaction\")))\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nlet parse_sapling_transaction_deprecated ctxt ~memo_size :\n Script.node -> (Sapling.Legacy.transaction * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\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 let* () =\n memo_size_eq\n ~error_details:(Informative ())\n memo_size\n transac_memo_size\n in\n return (transaction, ctxt))\n | None ->\n tzfail\n (Invalid_syntactic_constant\n ( loc,\n strip_locations expr,\n \"a valid Sapling transaction (deprecated format)\" )))\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nlet parse_chest_key ctxt :\n Script.node -> (Script_timelock.chest_key * context) tzresult =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\n let* ctxt = Gas.consume ctxt Typecheck_costs.chest_key in\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 ->\n tzfail\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid time-lock chest key\")))\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nlet parse_chest ctxt : Script.node -> (Script_timelock.chest * context) tzresult\n =\n let open Result_syntax in\n function\n | Bytes (loc, bytes) as expr -> (\n let* ctxt =\n Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes))\n in\n match\n Data_encoding.Binary.of_bytes_opt Script_timelock.chest_encoding bytes\n with\n | Some chest -> return (chest, ctxt)\n | None ->\n tzfail\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid time-lock chest\")))\n | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind 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 open Lwt_result_syntax in\n let parse_comb loc l rs =\n let* l, ctxt = parse_l ctxt l in\n let*? r =\n match (rs, r_comb_witness) with\n | [r], _ -> Ok r\n | [], _ -> Result_syntax.tzfail @@ 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 | _ ->\n Result_syntax.tzfail\n @@ Invalid_arity (loc, D_Pair, 2, 1 + List.length rs)\n in\n let+ r, ctxt = parse_r ctxt r in\n ((l, r), ctxt)\n in\n match expr with\n | Prim (loc, D_Pair, l :: rs, annot) ->\n let*? () =\n if legacy (* Legacy check introduced before Ithaca. *) then\n Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n 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_or parse_l parse_r ctxt ~legacy =\n let open Lwt_result_syntax in\n function\n | Prim (loc, D_Left, [v], annot) ->\n let*? () =\n if legacy (* Legacy check introduced before Ithaca. *) then\n Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n let+ v, ctxt = parse_l ctxt v in\n (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 let*? () =\n if legacy (* Legacy check introduced before Ithaca. *) then\n Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n let+ v, ctxt = parse_r ctxt v in\n (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 =\n let open Lwt_result_syntax in\n function\n | Prim (loc, D_Some, [v], annot) ->\n let*? () =\n if legacy (* Legacy check introduced before Ithaca. *) then\n Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n let+ v, ctxt = parse_v ctxt v in\n (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 let*? () =\n if legacy (* Legacy check introduced before Ithaca. *) then\n Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n return (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 let open Result_syntax in\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 tzfail (View_name_too_long v)\n else\n let rec check_char i =\n if Compare.Int.(i < 0) then return v\n else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1)\n else tzfail (Bad_view_name loc)\n in\n let* ctxt = Gas.consume ctxt (Typecheck_costs.check_printable v) in\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 (let* v = check_char (String.length v - 1) in\n let+ s = Script_string.of_string v in\n (s, ctxt))\n | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr)\n\nlet parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult =\n let open Result_syntax in\n fun ctxt toplevel ->\n record_trace (Ill_typed_contract (toplevel, []))\n @@\n match root toplevel with\n | Int (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Int_kind))\n | String (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], String_kind))\n | Bytes (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Bytes_kind))\n | Prim (loc, _, _, _) -> tzfail (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 | [] -> return (ctxt, (p, s, c, views))\n | Int (loc, _) :: _ ->\n tzfail (Invalid_kind (loc, [Prim_kind], Int_kind))\n | String (loc, _) :: _ ->\n tzfail (Invalid_kind (loc, [Prim_kind], String_kind))\n | Bytes (loc, _) :: _ ->\n tzfail (Invalid_kind (loc, [Prim_kind], Bytes_kind))\n | Seq (loc, _) :: _ ->\n tzfail (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 _ -> tzfail (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 _ -> tzfail (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 _ -> tzfail (Duplicate_field (loc, K_code)))\n | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _)\n :: _ ->\n tzfail (Invalid_arity (loc, name, 1, List.length args))\n | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _)\n :: rest ->\n let* str, ctxt = parse_view_name ctxt name in\n let* ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.view_update str views)\n in\n if Script_map.mem str views then tzfail (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 tzfail (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 tzfail (Invalid_primitive (loc, allowed, name))\n in\n let* ctxt, toplevel =\n find_fields ctxt None None None (Script_map.empty string_t) fields\n in\n match toplevel with\n | None, _, _, _ -> tzfail (Missing_field K_parameter)\n | Some _, None, _, _ -> tzfail (Missing_field K_storage)\n | Some _, Some _, None, _ -> tzfail (Missing_field K_code)\n | ( Some (p, ploc, pannot),\n Some (s, sloc, sannot),\n Some (c, cloc, cannot),\n views ) ->\n let* () = Script_ir_annot.error_unexpected_annot ploc pannot in\n let* () = Script_ir_annot.error_unexpected_annot cloc cannot in\n let+ () = Script_ir_annot.error_unexpected_annot sloc sannot in\n ({code_field = c; arg_type = p; 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 let open Lwt_result_syntax in\n let+ code_field, ctxt =\n unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) Optimized code_field\n in\n (Lam (kdescr, code_field), ctxt)\n\nlet normalized_lam_rec ~unparse_code_rec ~stack_depth ctxt kdescr code_field =\n let open Lwt_result_syntax in\n let+ code_field, ctxt =\n unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) Optimized code_field\n in\n (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], both [allow_forged_tickets] and [allow_forged_lazy_storage_id] should be [false] for:\n - PUSH\n - UNPACK\n - storage on origination\n And [true] for:\n - internal calls parameters\n - storage after origination.\n For\n - user-provided script parameters \n [allow_forged_lazy_storage_id] should be [false] but [allow_forged_tickets] should be [true] as users are allowed to transfer tickets. Checking ticket ownership is handled by the ticket table.\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_tickets:bool ->\n allow_forged_lazy_storage_id:bool ->\n (a, ac) ty ->\n Script.node ->\n (a * context) tzresult Lwt.t =\n fun ~unparse_code_rec\n ~elab_conf\n ~stack_depth\n ctxt\n ~allow_forged_tickets\n ~allow_forged_lazy_storage_id\n ty\n script_data ->\n let open Lwt_result_syntax in\n let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in\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_tickets\n ~allow_forged_lazy_storage_id\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 =\n Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err)\n in\n let parse_items ctxt expr key_type value_type items item_wrapper =\n let+ _, items, ctxt =\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 let*? () =\n if elab_conf.legacy (* Legacy check introduced before Ithaca. *)\n then Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n let* k, ctxt = non_terminal_recursion ctxt key_type k in\n let* v, ctxt = non_terminal_recursion ctxt value_type v in\n let*? ctxt =\n let open Result_syntax in\n match last_value with\n | Some value ->\n let* ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.compare\n key_type\n value\n k)\n in\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 tzfail (Duplicate_map_keys (loc, strip_locations expr))\n else\n tzfail (Unordered_map_keys (loc, strip_locations expr))\n else return ctxt\n | None -> return ctxt\n in\n let*? ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.map_update k map)\n in\n return\n (Some k, Script_map.update k (Some (item_wrapper v)) map, 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, Script_map.empty key_type, ctxt)\n items\n |> traced\n in\n (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 let+ _, map, ctxt =\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 let*? () =\n if elab_conf.legacy (* Legacy check introduced before Ithaca. *)\n then Result_syntax.return_unit\n else error_unexpected_annot loc annot\n in\n let* k, ctxt = non_terminal_recursion ctxt key_type k in\n let* key_hash, ctxt = hash_comparable_data ctxt key_type k in\n let* v, ctxt = non_terminal_recursion ctxt value_type v in\n let*? ctxt =\n let open Result_syntax in\n match last_key with\n | Some last_key ->\n let* ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.compare\n key_type\n last_key\n k)\n in\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 tzfail (Duplicate_map_keys (loc, strip_locations expr))\n else\n tzfail (Unordered_map_keys (loc, strip_locations expr))\n else return ctxt\n | None -> return ctxt\n in\n let*? ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.big_map_update\n {map; size})\n in\n if Big_map_overlay.mem key_hash map then\n tzfail (Duplicate_map_keys (loc, strip_locations expr))\n else\n return\n ( Some k,\n {\n map = 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 in\n (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 | Contract_t (arg_ty, _), expr ->\n traced\n (let*? address, ctxt = parse_address ctxt expr in\n let loc = location expr in\n let+ ctxt, typed_contract =\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 in\n (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 (* Ors *)\n | Or_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_or parse_l parse_r ctxt ~legacy expr\n (* Lambdas *)\n | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) ->\n let* kdescr, ctxt =\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 in\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 @@ let*? lambda_rec_ty = lambda_t loc ta tr in\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_left_es\n (fun (rest, ctxt) v ->\n let+ v, ctxt = non_terminal_recursion ctxt t v in\n (Script_list.cons v rest, ctxt))\n (Script_list.empty, ctxt)\n (List.rev items)\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 (* This local function handles the case of parsing the `Ticket` data constructor. *)\n let parse_ticket loc ticketer contents_type contents amount =\n (* Ensure that the content type provided in the ticket constructor\n matches the ticket type expected by the entrypoint. *)\n let*? Ex_ty expected, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy contents_type\n in\n let*? eq, ctxt =\n Gas_monad.run ctxt\n @@\n let error_details = Informative loc in\n ty_eq ~error_details t expected\n in\n let*? Eq = eq in\n let* {destination; entrypoint = _}, ctxt =\n non_terminal_recursion ctxt address_t ticketer\n in\n let* contents, ctxt = non_terminal_recursion ctxt t contents in\n let+ amount, ctxt = non_terminal_recursion ctxt nat_t amount in\n ((destination, contents, amount), ctxt)\n in\n if allow_forged_tickets then\n let* (destination, contents, amount), ctxt =\n match expr with\n | Prim\n ( loc,\n D_Ticket,\n [ticketer; contents_type; contents; amount],\n _annot ) ->\n parse_ticket loc ticketer contents_type contents amount\n | Prim (_, D_Pair, _, _) ->\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/6833\n\n In the future, this [D_Pair] constructor must\n be allowed only when the legacy flag is set to true. *)\n let*? ty = opened_ticket_type (location expr) t in\n let+ ({destination; entrypoint = _}, (contents, amount)), ctxt =\n non_terminal_recursion ctxt ty expr\n in\n ((destination, contents, amount), ctxt)\n | _ ->\n tzfail @@ unexpected expr [] Constant_namespace [D_Ticket; D_Pair]\n in\n match Ticket_amount.of_n amount with\n | Some amount -> (\n match destination with\n | Contract ticketer -> return ({ticketer; contents; amount}, ctxt)\n | 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 let+ _, set, ctxt =\n traced\n @@ List.fold_left_es\n (fun (last_value, set, ctxt) v ->\n let* v, ctxt = non_terminal_recursion ctxt t v in\n let*? ctxt =\n let open Result_syntax in\n match last_value with\n | Some value ->\n let* ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.compare\n t\n value\n v)\n in\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 tzfail\n (Duplicate_set_values (loc, strip_locations expr))\n else\n tzfail\n (Unordered_set_values (loc, strip_locations expr))\n else return ctxt\n | None -> return ctxt\n in\n let*? ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.set_update v set)\n in\n return (Some v, Script_set.update v true set, ctxt))\n (None, Script_set.empty t, ctxt)\n vs\n in\n (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 let* id_opt, diff, ctxt =\n match expr with\n | Int (loc, id) ->\n return\n (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt)\n | Seq (_, vs) ->\n let+ diff, ctxt =\n parse_big_map_items ctxt expr tk tv vs (fun x -> Some x)\n in\n (None, diff, ctxt)\n | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) ->\n let*? () = error_unexpected_annot loc annot in\n let*? tv_opt = option_t loc tv in\n let+ diff, ctxt =\n parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x)\n in\n (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 in\n let+ id, ctxt =\n match id_opt with\n | None -> return (None, ctxt)\n | Some (id, loc) ->\n if allow_forged_lazy_storage_id then\n let id = Big_map.Id.parse_z id in\n let* ctxt, tys_opt = Big_map.exists ctxt id in\n match tys_opt with\n | None -> traced_fail (Invalid_big_map (loc, id))\n | Some (btk, btv) ->\n let*? Ex_comparable_ty btk, ctxt =\n parse_comparable_ty\n ~stack_depth:(stack_depth + 1)\n ctxt\n (Micheline.root btk)\n in\n let*? Ex_ty btv, ctxt =\n parse_big_map_value_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n (Micheline.root btv)\n in\n let*? eq, 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 in\n let*? Eq = eq in\n return (Some id, ctxt)\n else traced_fail (Unexpected_forged_value loc)\n in\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, expr ->\n Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g1 ctxt expr\n | Bls12_381_g2_t, expr ->\n Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g2 ctxt expr\n | Bls12_381_fr_t, expr ->\n Lwt.return @@ traced_no_lwt @@ parse_bls12_381_fr ctxt expr\n (*\n /!\\ When adding new lazy storage kinds, you may want to guard the parsing\n of identifiers with [allow_forged_lazy_storage_id].\n *)\n (* Sapling *)\n | Sapling_transaction_t memo_size, expr ->\n Lwt.return @@ traced_no_lwt\n @@ parse_sapling_transaction ctxt ~memo_size expr\n | Sapling_transaction_deprecated_t memo_size, expr ->\n Lwt.return @@ traced_no_lwt\n @@ parse_sapling_transaction_deprecated ctxt ~memo_size expr\n | Sapling_state_t memo_size, Int (loc, id) ->\n if allow_forged_lazy_storage_id then\n let id = Sapling.Id.parse_z id in\n let* state, ctxt = Sapling.state_from_id ctxt id in\n let*? () =\n traced_no_lwt\n @@ memo_size_eq\n ~error_details:(Informative ())\n memo_size\n state.Sapling.memo_size\n in\n return (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, expr ->\n Lwt.return @@ traced_no_lwt @@ parse_chest_key ctxt expr\n | Chest_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chest ctxt 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 let open Lwt_result_syntax in\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 let*? Ex_ty input_ty, ctxt =\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 in\n let output_ty_loc = location output_ty in\n let*? Ex_ty output_ty, ctxt =\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 in\n let*? (Ty_ex_c pair_ty) = pair_t input_ty_loc input_ty storage_type in\n let* judgement, ctxt =\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 in\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 let open Result_syntax in\n match aft with\n | Item_t (ty, Bot_t) ->\n let error_details = Informative loc in\n let* eq, ctxt =\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 in\n let* Eq = eq in\n let {kinstr; _} = close_descr descr in\n Ok\n ( Typed_view\n {input_ty; output_ty; kinstr; original_code_expr = view_code},\n ctxt )\n | _ -> tzfail (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 let open Lwt_result_syntax in\n fun ~unparse_code_rec ~elab_conf ctxt storage_type views ->\n let aux ctxt name cur_view =\n let*? ctxt =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.view_update name views)\n in\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 let open Lwt_result_syntax in\n fun ~unparse_code_rec\n ~elab_conf\n ~stack_depth\n tc_context\n ctxt\n arg\n ret\n script_instr ->\n let* result =\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 in\n match result with\n | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt ->\n let error_details = Informative loc in\n let*? eq, ctxt =\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 in\n let*? Eq = eq in\n return\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 let open Lwt_result_syntax in\n let* result =\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 in\n match result with\n | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt ->\n let*? closed_descr, ctxt =\n let open Result_syntax in\n let error_details = Informative loc in\n let* eq, ctxt =\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 in\n let* Eq = eq in\n Ok\n ( (close_descr descr\n : ( arg,\n (arg, ret) lambda * end_of_stack,\n ret,\n end_of_stack )\n kdescr),\n ctxt )\n in\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 open Lwt_result_syntax in\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 let open Result_syntax in\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 (let* eq, ctxt =\n Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) exp got\n in\n let* Eq = eq in\n Ok ((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 let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\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 Result_syntax.tzfail\n (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 (let*? () = error_unexpected_annot loc annot in\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 let*? whole_n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in\n let rec make_proof_argument :\n type a s.\n int -> (a, s) stack_ty -> (a, s) dropn_proof_argument tzresult =\n let open Result_syntax in\n fun n stk ->\n match (Compare.Int.(n = 0), stk) with\n | true, rest -> return (Dropn_proof_argument (KRest, rest))\n | false, Item_t (a, rest) ->\n let+ (Dropn_proof_argument (n', stack_after_drops)) =\n make_proof_argument (n - 1) rest\n in\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 tzfail (Bad_stack (loc, I_DROP, whole_n, whole_stack))\n in\n let*? () = error_unexpected_annot loc result_annot in\n let*? (Dropn_proof_argument (n', stack_after_drops)) =\n make_proof_argument whole_n whole_stack\n in\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 let*? () = check_var_annot loc annot in\n let*? ctxt =\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 in\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 let*? () = check_var_annot loc v_annot in\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 let open Result_syntax in\n fun n (stack_ty : (a, b * s) stack_ty) ->\n match (n, stack_ty) with\n | 1, Item_t (hd_ty, _) ->\n return (Dup_n_proof_argument (Dup_n_zero, hd_ty))\n | n, Item_t (_, (Item_t (_, _) as tl_ty)) ->\n let+ (Dup_n_proof_argument (dup_n_witness, b_ty)) =\n make_proof_argument (n - 1) tl_ty\n in\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 let*? n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\n let*? () =\n error_unless (Compare.Int.( > ) n 0) (Dup_n_bad_argument loc)\n in\n let*? (Dup_n_proof_argument (witness, after_ty)) =\n record_trace (Dup_n_bad_stack loc) (make_proof_argument n stack_ty)\n in\n let*? ctxt =\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 in\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 let open Result_syntax in\n fun n stk ->\n match (Compare.Int.(n = 0), stk) with\n | true, Item_t (v, rest) ->\n return @@ Dig_proof_argument (KRest, v, rest)\n | false, Item_t (v, rest) ->\n let+ (Dig_proof_argument (n', x, aft')) =\n make_proof_argument (n - 1) rest\n in\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 tzfail (Bad_stack (loc, I_DIG, 3, whole_stack))\n in\n let*? n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\n let*? () = error_unexpected_annot loc result_annot in\n let*? (Dig_proof_argument (n', x, aft)) = make_proof_argument n stack in\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 let*? whole_n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in\n let*? () = error_unexpected_annot loc result_annot in\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 let*? () = error_unexpected_annot loc result_annot in\n let stack = serialize_stack_for_error ctxt stack in\n tzfail (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 let*? () = error_unexpected_annot loc annot in\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 let*? () = check_var_annot loc annot in\n let*? Ex_ty t, ctxt =\n parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t\n in\n let* v, ctxt =\n parse_data\n ~unparse_code_rec\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n ~allow_forged_tickets:false\n ~allow_forged_lazy_storage_id:false\n t\n d\n in\n let push = {apply = (fun k -> IPush (loc, t, v, k))} in\n typed ctxt loc push (Item_t (t, stack))\n | Prim (loc, I_UNIT, [], annot), stack ->\n let*? () = check_var_type_annot loc annot in\n let unit = {apply = (fun k -> IUnit (loc, k))} in\n typed ctxt loc unit (Item_t (unit_t, stack))\n (* options *)\n | Prim (loc, I_SOME, [], annot), Item_t (t, rest) ->\n let*? () = check_var_type_annot loc annot in\n let cons_some = {apply = (fun k -> ICons_some (loc, k))} in\n let*? ty = option_t loc t in\n typed ctxt loc cons_some (Item_t (ty, rest))\n | Prim (loc, I_NONE, [t], annot), stack ->\n let*? Ex_ty t, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t\n in\n let*? () = check_var_type_annot loc annot in\n let cons_none = {apply = (fun k -> ICons_none (loc, t, k))} in\n let*? ty = option_t loc t in\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 let*? () = check_kind [Seq_kind] body in\n let*? () = check_var_type_annot loc annot in\n let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt body (Item_t (t, rest))\n in\n let open Result_syntax in\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 (let* Eq, ctxt = stack_eq loc ctxt 1 aft_rest rest in\n let* opt_ty = option_t loc ret in\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 tzfail (Invalid_map_body (loc, aft))\n | Failed _ -> tzfail (Invalid_map_block_fail loc))\n | ( Prim (loc, I_IF_NONE, [bt; bf], annot),\n (Item_t (Option_t (t, _, _), rest) as bef) ) ->\n let*? () = check_kind [Seq_kind] bt in\n let*? () = check_kind [Seq_kind] bf in\n let*? () = error_unexpected_annot loc annot in\n let* btr, ctxt = non_terminal_recursion tc_context ctxt bt rest in\n let stack_ty = Item_t (t, rest) in\n let* bfr, ctxt = non_terminal_recursion tc_context ctxt bf stack_ty in\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 let*? () = check_constr_annot loc annot in\n let*? (Ty_ex_c ty) = pair_t loc a b in\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 let*? () = check_var_annot loc annot in\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 let open Result_syntax in\n fun n stack_ty ->\n match (n, stack_ty) with\n | 1, Item_t _ -> return (Comb_proof_argument (Comb_one, stack_ty))\n | n, Item_t (a_ty, (Item_t _ as tl_ty)) ->\n let* (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) =\n make_proof_argument (n - 1) tl_ty\n in\n let+ (Ty_ex_c pair_t) = pair_t loc a_ty b_ty in\n Comb_proof_argument\n (Comb_succ comb_witness, Item_t (pair_t, tl_ty'))\n | _ -> bad_stack_error ctxt loc I_PAIR 1\n in\n let*? n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\n let*? () = error_unless (Compare.Int.( > ) n 1) (Pair_bad_argument loc) in\n let*? (Comb_proof_argument (witness, after_ty)) =\n make_proof_argument n stack_ty\n in\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 let*? () = error_unexpected_annot loc annot in\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 let open Result_syntax in\n fun n stack_ty ->\n match (n, stack_ty) with\n | 1, (Item_t _ as stack) ->\n return (Uncomb_proof_argument (Uncomb_one, stack))\n | n, Item_t (Pair_t (a_ty, b_ty, _, _), tl_ty) ->\n let+ (Uncomb_proof_argument (uncomb_witness, after_ty)) =\n make_proof_argument (n - 1) (Item_t (b_ty, tl_ty))\n in\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 let*? n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\n let*? () =\n error_unless (Compare.Int.( > ) n 1) (Unpair_bad_argument loc)\n in\n let*? (Uncomb_proof_argument (witness, after_ty)) =\n make_proof_argument n stack_ty\n in\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 let*? () = check_var_annot loc annot in\n let*? n = parse_uint11 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\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 let*? () = check_var_annot loc annot in\n let*? n = parse_uint11 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\n let*? (Comb_set_proof_argument (witness, after_ty)) =\n make_comb_set_proof_argument ctxt stack_ty loc n value_ty comb_ty\n in\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 let*? () = check_unpair_annot loc annot in\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 let*? () = check_destr_annot loc annot in\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 let*? () = check_destr_annot loc annot in\n let cdr = {apply = (fun k -> ICdr (loc, k))} in\n typed ctxt loc cdr (Item_t (b, rest))\n (* ors *)\n | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) ->\n let*? Ex_ty tr, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr\n in\n let*? () = check_constr_annot loc annot in\n let cons_left = {apply = (fun k -> ICons_left (loc, tr, k))} in\n let*? (Ty_ex_c ty) = or_t loc tl tr in\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 let*? Ex_ty tl, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl\n in\n let*? () = check_constr_annot loc annot in\n let cons_right = {apply = (fun k -> ICons_right (loc, tl, k))} in\n let*? (Ty_ex_c ty) = or_t loc tl tr in\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 (Or_t (tl, tr, _, _), rest) as bef) ) ->\n let*? () = check_kind [Seq_kind] bt in\n let*? () = check_kind [Seq_kind] bf in\n let*? () = error_unexpected_annot loc annot in\n let* btr, ctxt =\n non_terminal_recursion tc_context ctxt bt (Item_t (tl, rest))\n in\n let* bfr, ctxt =\n non_terminal_recursion tc_context ctxt bf (Item_t (tr, rest))\n in\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 let*? Ex_ty t, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t\n in\n let*? () = check_var_type_annot loc annot in\n let nil = {apply = (fun k -> INil (loc, t, k))} in\n let*? ty = list_t loc t in\n 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 let*? Eq, ctxt = check_item_ty ctxt tv t loc I_CONS 1 2 in\n let*? () = check_var_annot loc annot in\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 let*? () = check_kind [Seq_kind] bt in\n let*? () = check_kind [Seq_kind] bf in\n let*? () = error_unexpected_annot loc annot in\n let* btr, ctxt =\n non_terminal_recursion tc_context ctxt bt (Item_t (t, bef))\n in\n let* bfr, ctxt = non_terminal_recursion tc_context ctxt bf rest in\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 let*? () = check_var_type_annot loc annot in\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 let*? () = check_kind [Seq_kind] body in\n let*? () = check_var_type_annot loc annot in\n let* judgement, ctxt =\n non_terminal_recursion\n tc_context\n ctxt\n body\n (Item_t (elt, starting_rest))\n in\n let open Result_syntax in\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 (let* Eq, ctxt = stack_eq loc ctxt 1 rest starting_rest in\n let hloc = loc in\n let ibody = kibody.instr.apply (IHalt hloc) in\n let* ty = list_t loc ret in\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 tzfail (Invalid_map_body (loc, aft))\n | Failed _ -> tzfail (Invalid_map_block_fail loc))\n | Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest) -> (\n let*? () = check_kind [Seq_kind] body in\n let*? () = error_unexpected_annot loc annot in\n let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt body (Item_t (elt, rest))\n in\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 let open Result_syntax 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 (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in\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 let*? Ex_comparable_ty t, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t\n in\n let*? () = check_var_type_annot loc annot in\n let instr = {apply = (fun k -> IEmpty_set (loc, t, k))} in\n let*? ty = set_t loc t in\n typed ctxt loc instr (Item_t (ty, rest))\n | Prim (loc, I_ITER, [body], annot), Item_t (Set_t (elt, _), rest) -> (\n let*? () = check_kind [Seq_kind] body in\n let*? () = error_unexpected_annot loc annot in\n let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt body (Item_t (elt, rest))\n in\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 let open Result_syntax 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 (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in\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 let*? () = check_var_type_annot loc annot in\n let*? Eq, ctxt = check_item_ty ctxt elt v loc I_MEM 1 2 in\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 let*? Eq, ctxt = check_item_ty ctxt elt v loc I_UPDATE 1 3 in\n let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? Ex_comparable_ty tk, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk\n in\n let*? Ex_ty tv, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv\n in\n let*? () = check_var_type_annot loc annot in\n let instr =\n {apply = (fun k -> IEmpty_map (loc, tk, for_logging_only tv, k))}\n in\n let*? ty = map_t loc tk tv in\n 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 let*? () = check_kind [Seq_kind] body in\n let*? () = check_var_type_annot loc annot in\n let*? (Ty_ex_c ty) = pair_t loc kt elt in\n let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt body (Item_t (ty, starting_rest))\n in\n let open Result_syntax in\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 (let* Eq, ctxt = stack_eq loc ctxt 1 rest starting_rest in\n let* ty = map_t loc kt ret in\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 tzfail (Invalid_map_body (loc, aft))\n | Failed _ -> tzfail (Invalid_map_block_fail loc))\n | Prim (loc, I_ITER, [body], annot), Item_t (Map_t (key, element_ty, _), rest)\n -> (\n let*? () = check_kind [Seq_kind] body in\n let*? () = error_unexpected_annot loc annot in\n let*? (Ty_ex_c ty) = pair_t loc key element_ty in\n let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt body (Item_t (ty, rest))\n in\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 let open Result_syntax 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 (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in\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 let*? Eq, ctxt = check_item_ty ctxt vk k loc I_MEM 1 2 in\n let*? () = check_var_annot loc annot in\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 let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET 1 2 in\n let*? () = check_var_annot loc annot in\n let instr = {apply = (fun k -> IMap_get (loc, k))} in\n let*? ty = option_t loc elt in\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 ( vk,\n Item_t (Option_t (vv, _, _), (Item_t (Map_t (k, v, _), _) as stack))\n ) ) ->\n let*? Eq, ctxt = check_item_ty ctxt vk k loc I_UPDATE 1 3 in\n let*? Eq, ctxt = check_item_ty ctxt vv v loc I_UPDATE 2 3 in\n let*? () = check_var_annot loc annot in\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 let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 in\n let*? Eq, ctxt = check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 in\n let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? Ex_comparable_ty tk, ctxt =\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk\n in\n let*? Ex_ty tv, ctxt =\n parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv\n in\n let*? () = check_var_type_annot loc annot in\n let instr = {apply = (fun k -> IEmpty_big_map (loc, tk, tv, k))} in\n let*? ty = big_map_t loc tk tv in\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 let*? Eq, ctxt = check_item_ty ctxt set_key k loc I_MEM 1 2 in\n let*? () = check_var_annot loc annot in\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 let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET 1 2 in\n let*? () = check_var_annot loc annot in\n let instr = {apply = (fun k -> IBig_map_get (loc, k))} in\n let*? ty = option_t loc elt in\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 let*? Eq, ctxt = check_item_ty ctxt set_key map_key loc I_UPDATE 1 3 in\n let*? Eq, ctxt =\n check_item_ty ctxt set_value map_value loc I_UPDATE 2 3\n in\n let*? () = check_var_annot loc annot in\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 let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 in\n let*? Eq, ctxt = check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 in\n let*? () = check_var_annot loc annot in\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 let*? memo_size = parse_memo_size memo_size in\n let*? () = check_var_annot loc annot in\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 (* Legacy check introduced in Jakarta. *) then\n let*? () =\n memo_size_eq\n ~error_details:(Informative ())\n state_memo_size\n transaction_memo_size\n in\n let instr =\n {apply = (fun k -> ISapling_verify_update_deprecated (loc, k))}\n in\n let*? (Ty_ex_c pair_ty) = pair_t loc int_t state_ty in\n let*? ty = option_t loc pair_ty in\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 let*? () =\n memo_size_eq\n ~error_details:(Informative ())\n state_memo_size\n transaction_memo_size\n in\n let instr = {apply = (fun k -> ISapling_verify_update (loc, k))} in\n let*? (Ty_ex_c pair_ty) = pair_t loc int_t state_ty in\n let*? (Ty_ex_c pair_ty) = pair_t loc bytes_t pair_ty in\n let*? ty = option_t loc pair_ty in\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 let* judgement, ctxt = non_terminal_recursion tc_context ctxt hd stack in\n match judgement with\n | Failed _ -> tzfail (Fail_not_in_tail_position (Micheline.location hd))\n | Typed ({aft = middle; _} as ihd) ->\n let+ judgement, ctxt =\n non_terminal_recursion\n tc_context\n ctxt\n (Seq (Micheline.dummy_location, tl))\n middle\n in\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 let*? () = check_kind [Seq_kind] bt in\n let*? () = check_kind [Seq_kind] bf in\n let*? () = error_unexpected_annot loc annot in\n let* btr, ctxt = non_terminal_recursion tc_context ctxt bt rest in\n let* bfr, ctxt = non_terminal_recursion tc_context ctxt bf rest in\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 let*? () = check_kind [Seq_kind] body in\n let*? () = error_unexpected_annot loc annot in\n let* judgement, ctxt = non_terminal_recursion tc_context ctxt body rest in\n let open Result_syntax in\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 (let* Eq, ctxt = stack_eq loc ctxt 1 ibody.aft stack in\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 (Or_t (tl, tr, _, _), rest) as stack) ) -> (\n let*? () = check_kind [Seq_kind] body in\n let*? () = check_var_annot loc annot in\n let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt body (Item_t (tl, rest))\n in\n let open Result_syntax in\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 (let* Eq, ctxt = stack_eq loc ctxt 1 ibody.aft stack in\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 let*? Ex_ty arg, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg\n in\n let*? Ex_ty ret, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret\n in\n let*? () = check_kind [Seq_kind] code in\n let*? () = check_var_annot loc annot in\n let* kdescr, ctxt =\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 in\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 let*? ty = lambda_t loc arg ret in\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 let*? Ex_ty arg, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr\n in\n let*? Ex_ty ret, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr\n in\n let*? () = check_kind [Seq_kind] lambda_expr in\n let*? () = check_var_annot loc annot in\n let*? lambda_rec_ty = lambda_t loc arg ret in\n let* code, ctxt =\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 in\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 let*? Eq, ctxt = check_item_ty ctxt arg param loc I_EXEC 1 2 in\n let*? () = check_var_annot loc annot in\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 let*? () = check_packable ~allow_contract:false loc capture_ty in\n let*? Eq, ctxt = check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 in\n let*? () = check_var_annot loc annot in\n let instr = {apply = (fun k -> IApply (loc, capture_ty, k))} in\n let*? res_ty =\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 in\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 let*? () = error_unexpected_annot loc annot in\n let*? () = check_kind [Seq_kind] code in\n let* judgement, ctxt = non_terminal_recursion tc_context ctxt code rest in\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 let*? n = parse_uint10 n in\n let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in\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 let* judgement, ctxt =\n non_terminal_recursion tc_context ctxt code rest\n in\n match judgement with\n | Typed descr ->\n return\n (Dipn_proof_argument (KRest, ctxt, descr, descr.aft)\n : (a, s) dipn_proof_argument)\n | Failed _ -> tzfail (Fail_not_in_tail_position loc))\n | false, Item_t (v, rest) ->\n let+ (Dipn_proof_argument (n', ctxt, descr, aft')) =\n make_proof_argument (n - 1) rest\n in\n let w = KPrefix (loc, v, n') in\n Dipn_proof_argument (w, ctxt, descr, Item_t (v, aft'))\n | _, _ ->\n let whole_stack = serialize_stack_for_error ctxt stack in\n tzfail (Bad_stack (loc, I_DIP, 1, whole_stack))\n in\n let*? () = error_unexpected_annot loc result_annot in\n let* (Dipn_proof_argument (n', ctxt, descr, aft)) =\n make_proof_argument n stack\n in\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 let*? () = error_unexpected_annot loc annot in\n let*? () = check_packable ~allow_contract:false loc v in\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 return (Failed {descr}, ctxt)\n | Prim (loc, I_NEVER, [], annot), Item_t (Never_t, _rest) ->\n let*? () = error_unexpected_annot loc annot in\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 return (Failed {descr}, ctxt)\n (* timestamp operations *)\n | Prim (loc, I_ADD, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) ->\n let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 (* Legacy check introduced in Ithaca. *) then\n let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\n let*? Eq, ctxt = check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 in\n let*? Eq = check_comparable loc t1 in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\n let*? Ex_ty cast_t, ctxt =\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t\n in\n let*? eq, ctxt =\n Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t\n in\n let*? Eq = eq in\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 let*? () = check_var_annot loc annot in\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 let*? () =\n check_packable\n ~allow_contract:true\n (* allow to pack contracts for hash/signature checks *) loc\n t\n in\n let*? () = check_var_annot loc annot in\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 let*? Ex_ty t, ctxt =\n parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty\n in\n let*? () = check_var_type_annot loc annot in\n let*? res_ty = option_t loc t in\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 let*? () = check_var_annot loc annot in\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 let*? Ex_ty t, ctxt =\n parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty\n in\n let*? contract_ty = contract_t loc t in\n let*? res_ty = option_t loc contract_ty in\n let*? entrypoint = parse_entrypoint_annot_strict loc annot in\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 let*? name, ctxt = parse_view_name ctxt name in\n let*? Ex_ty output_ty, ctxt =\n parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty\n in\n let*? res_ty = option_t output_ty_loc output_ty in\n let*? () = check_var_annot loc annot in\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 let*? () = Tc_context.check_not_in_view loc ~legacy tc_context prim in\n let*? Eq, ctxt = check_item_ty ctxt p cp loc prim 1 4 in\n let*? () = check_var_annot loc annot in\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 let*? () = Tc_context.check_not_in_view loc ~legacy tc_context prim in\n let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = Tc_context.check_not_in_view ~legacy loc tc_context prim in\n let*? () = check_two_var_annot loc annot in\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 let*? {arg_type; storage_type; code_field; views}, ctxt =\n parse_toplevel ctxt canonical_code\n in\n let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, 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 in\n let*? Ex_ty storage_type, ctxt =\n record_trace\n (Ill_formed_type\n (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 in\n let*? (Ty_ex_c arg_type_full) = pair_t loc arg_type storage_type in\n let*? (Ty_ex_c ret_type_full) =\n pair_t loc list_operation_t storage_type\n in\n let* result =\n trace\n (Ill_typed_contract (canonical_code, []))\n (parse_kdescr\n ~unparse_code_rec\n (Tc_context.toplevel\n ~storage_type\n ~param_type:arg_type\n ~entrypoints)\n ctxt\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n arg_type_full\n ret_type_full\n code_field)\n in\n match result with\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 let* _typed_views, ctxt =\n trace (Ill_typed_contract (canonical_code, [])) views_result\n in\n let*? storage_eq, 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 in\n let*? Eq = storage_eq in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? entrypoint = parse_entrypoint_annot_lax loc annot in\n let open Tc_context in\n match tc_context.callsite with\n | _ when is_in_lambda tc_context ->\n tzfail\n (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim))\n (* [Data] is for pushed instructions of lambda type. *)\n | Data ->\n tzfail\n (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim))\n | View ->\n tzfail (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim))\n | Toplevel {param_type; entrypoints; storage_type = _} ->\n let*? r, ctxt =\n Gas_monad.run ctxt\n @@ find_entrypoint\n ~error_details:(Informative ())\n param_type\n entrypoints\n entrypoint\n in\n let*? (Ex_ty_cstr {ty = param_type; _}) = r in\n let*? res_ty = contract_t loc param_type in\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 ctxt loc instr stack)\n | Prim (loc, I_SELF_ADDRESS, [], annot), stack ->\n let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\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 let*? () = check_var_annot loc annot in\n let*? Eq = check_comparable loc t in\n let*? res_ty = ticket_t loc t in\n let instr = {apply = (fun k -> ITicket (loc, for_logging_only t, k))} in\n let*? res_ty = option_t loc res_ty in\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 let*? () = check_var_annot loc annot in\n let*? Eq = check_comparable loc t in\n let*? res_ty = ticket_t loc t in\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 let*? () = check_var_annot loc annot in\n let () = check_dupable_comparable_ty t in\n let*? result = opened_ticket_type loc t in\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 let*? () = check_var_annot loc annot in\n let () = check_dupable_comparable_ty t in\n let*? (Ty_ex_c pair_tickets_ty) = pair_t loc ticket_t ticket_t in\n let*? res_ty = option_t loc pair_tickets_ty in\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 let*? () = check_var_annot loc annot in\n let*? eq, ctxt =\n Gas_monad.run ctxt\n @@ ty_eq ~error_details:(Informative loc) contents_ty_a contents_ty_b\n in\n let*? Eq = eq in\n let*? res_ty = option_t loc ty_a in\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 let instr = {apply = (fun k -> IOpen_chest (loc, k))} in\n typed ctxt loc instr (Item_t (option_bytes_t, rest))\n (* Events *)\n | Prim (loc, I_EMIT, [], annot), Item_t (data, rest) ->\n let*? () = check_packable ~allow_contract:false loc data in\n let*? tag = parse_entrypoint_annot_strict loc annot in\n let*? unparsed_ty, ctxt = unparse_ty ~loc:() ctxt data in\n let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed_ty) in\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 let*? Ex_ty ty, ctxt =\n parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty_node\n in\n let*? Eq, ctxt = check_item_ty ctxt ty data loc I_EMIT 1 2 in\n let*? tag = parse_entrypoint_annot_strict loc annot in\n let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost ty_node) in\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 let stack = serialize_stack_for_error ctxt stack in\n tzfail (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 let stack = serialize_stack_for_error ctxt stack in\n tzfail (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 let stack = serialize_stack_for_error ctxt stack in\n tzfail (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 let stack = serialize_stack_for_error ctxt stack in\n tzfail (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 let open Lwt_result_syntax in\n fun ~stack_depth ctxt loc arg destination ~entrypoint ->\n let error_details = Informative loc in\n let* ctxt, res =\n parse_contract\n ~stack_depth:(stack_depth + 1)\n ctxt\n ~error_details\n loc\n arg\n destination\n ~entrypoint\n in\n let*? res in\n return (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 let open Lwt_result_syntax in\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 let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\n match destination with\n | Contract contract -> (\n match contract with\n | Implicit destination ->\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.ty_eq_prim 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\n @@ Unexpected_implicit_account_parameters_type\n (loc, serialize_ty_for_error arg))\n in\n let*? v, ctxt = Gas_monad.run ctxt typecheck in\n return (ctxt, v)\n else\n (* An implicit account on any other entrypoint is not a valid contract. *)\n return @@ error ctxt (fun _loc -> No_such_entrypoint entrypoint)\n | Originated contract_hash ->\n trace\n (Invalid_contract (loc, contract))\n (let* ctxt, code = Contract.get_script_code ctxt contract_hash in\n match code with\n | None ->\n return\n (error ctxt (fun loc -> Invalid_contract (loc, contract)))\n | Some code ->\n let*? code, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n code\n in\n (* can only fail because of gas *)\n let*? {arg_type; _}, ctxt = parse_toplevel ctxt code in\n let*? ( Ex_parameter_ty_and_entrypoints\n {arg_type = targ; entrypoints},\n ctxt ) =\n parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:true\n arg_type\n in\n let*? entrypoint_arg, 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 in\n return\n ( ctxt,\n let open Result_syntax in\n let* entrypoint, arg_ty = entrypoint_arg in\n Ok (Typed_originated {arg_ty; contract_hash; entrypoint})\n )))\n | Zk_rollup zk_rollup ->\n let+ ctxt = Zk_rollup.assert_exist ctxt zk_rollup in\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\n (loc, serialize_ty_for_error arg))\n else error ctxt (fun _loc -> No_such_entrypoint entrypoint)\n | Sc_rollup sc_rollup -> (\n let* parameters_type, ctxt = Sc_rollup.parameters_type ctxt sc_rollup in\n match parameters_type with\n | None ->\n return\n (error ctxt (fun _loc ->\n Sc_rollup.Errors.Sc_rollup_does_not_exist sc_rollup))\n | Some parameters_type ->\n let*? parameters_type, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n parameters_type\n in\n let*? ( Ex_parameter_ty_and_entrypoints\n {arg_type = full; entrypoints},\n ctxt ) =\n parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:true\n (root parameters_type)\n in\n let*? entrypoint_arg, ctxt =\n Gas_monad.run ctxt\n @@ find_entrypoint_for_type\n ~error_details\n ~full\n ~expected:arg\n entrypoints\n entrypoint\n in\n return\n ( ctxt,\n let open Result_syntax in\n let* entrypoint, arg_ty = entrypoint_arg in\n Ok (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 let open Lwt_result_syntax in\n fun ctxt loc arg destination ~entrypoint ->\n let+ ctxt, res =\n parse_contract\n ~stack_depth:0\n ctxt\n ~error_details:Fast\n loc\n arg\n destination\n ~entrypoint\n in\n ( ctxt,\n match res with\n | Ok res -> Some res\n | 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 Result_syntax in\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 let+ ctxt = Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) in\n (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 let open Lwt_result_syntax in\n fun ~unparse_code_rec ~elab_conf ctxt ~code ->\n let*? code, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n code\n in\n let legacy = elab_conf.legacy in\n let* ctxt, code = Global_constants_storage.expand ctxt code in\n let*? {arg_type; storage_type; code_field; views}, ctxt =\n parse_toplevel ctxt code\n in\n let arg_type_loc = location arg_type in\n let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt =\n record_trace\n (Ill_formed_type (Some \"parameter\", code, arg_type_loc))\n (parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:0\n ~legacy\n arg_type)\n in\n let storage_type_loc = location storage_type in\n let*? Ex_ty storage_type, ctxt =\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 in\n let*? (Ty_ex_c arg_type_full) =\n pair_t storage_type_loc arg_type storage_type\n in\n let*? (Ty_ex_c ret_type_full) =\n pair_t storage_type_loc list_operation_t storage_type\n in\n let* kdescr, ctxt =\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 in\n let code = Lam (kdescr, code_field) in\n let*? code_size, ctxt = code_size ctxt code views in\n return\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_tickets:bool ->\n allow_forged_lazy_storage_id:bool ->\n ('storage, _) ty ->\n storage:lazy_expr ->\n ('storage * context) tzresult Lwt.t =\n let open Lwt_result_syntax in\n fun ~unparse_code_rec\n ~elab_conf\n ctxt\n ~allow_forged_tickets\n ~allow_forged_lazy_storage_id\n storage_type\n ~storage ->\n let*? storage, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n storage\n in\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_tickets\n ~allow_forged_lazy_storage_id\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_tickets_in_storage:bool ->\n allow_forged_lazy_storage_id_in_storage:bool ->\n Script.t ->\n (ex_script * context) tzresult Lwt.t =\n let open Lwt_result_syntax in\n fun ~unparse_code_rec\n ~elab_conf\n ctxt\n ~allow_forged_tickets_in_storage\n ~allow_forged_lazy_storage_id_in_storage\n {code; storage} ->\n let* ( Ex_code\n (Code\n {code; arg_type; storage_type; views; entrypoints; code_size}),\n ctxt ) =\n parse_code ~unparse_code_rec ~elab_conf ctxt ~code\n in\n let+ storage, ctxt =\n parse_storage\n ~unparse_code_rec\n ~elab_conf\n ctxt\n ~allow_forged_tickets:allow_forged_tickets_in_storage\n ~allow_forged_lazy_storage_id:allow_forged_lazy_storage_id_in_storage\n storage_type\n ~storage\n in\n ( Ex_script\n (Script\n {\n code_size;\n code;\n arg_type;\n storage;\n storage_type;\n views;\n entrypoints;\n }),\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 let open Lwt_result_syntax in\n fun ~unparse_code_rec ~legacy ~show_types ctxt code ->\n (* Constants need to be expanded or [parse_toplevel] may fail. *)\n let* ctxt, code = Global_constants_storage.expand ctxt code in\n let*? toplevel, ctxt = parse_toplevel ctxt code in\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 let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt =\n record_trace\n (Ill_formed_type (Some \"parameter\", code, arg_type_loc))\n (parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:0\n ~legacy\n arg_type)\n in\n let storage_type_loc = location storage_type in\n let*? ex_storage_type, ctxt =\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 in\n let (Ex_ty storage_type) = ex_storage_type in\n let*? (Ty_ex_c arg_type_full) =\n pair_t storage_type_loc arg_type storage_type\n in\n let*? (Ty_ex_c ret_type_full) =\n pair_t storage_type_loc list_operation_t storage_type\n in\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 let* (_ : (_, _, _, _) kdescr), ctxt =\n trace (Ill_typed_contract (code, !type_map)) result\n in\n let views_result =\n parse_views ~unparse_code_rec ctxt ~elab_conf storage_type views\n in\n let+ typed_views, ctxt =\n trace (Ill_typed_contract (code, !type_map)) views_result\n in\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 | Or_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 | Or_t (tl, tr, _, _), {nested = Entrypoints_Or {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 let open Lwt_result_syntax in\n fun ctxt ~stack_depth mode node ->\n let* code, ctxt = unparse_code ctxt ~stack_depth mode node in\n return (Micheline.root code, ctxt)\n\nlet parse_and_unparse_script_unaccounted ctxt ~legacy\n ~allow_forged_tickets_in_storage ~allow_forged_lazy_storage_id_in_storage\n mode ~normalize_types {code; storage} =\n let open Lwt_result_syntax in\n let*? code, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n code\n in\n let* ( 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 typecheck_code ~unparse_code_rec ~legacy ~show_types:false ctxt code\n in\n let* storage, ctxt =\n parse_storage\n ~unparse_code_rec\n ~elab_conf:(Script_ir_translator_config.make ~legacy ())\n ctxt\n ~allow_forged_tickets:allow_forged_tickets_in_storage\n ~allow_forged_lazy_storage_id:allow_forged_lazy_storage_id_in_storage\n storage_type\n ~storage\n in\n let* code, ctxt = unparse_code ctxt ~stack_depth:0 mode code_field in\n let* storage, ctxt =\n unparse_data ctxt ~stack_depth:0 mode storage_type storage\n in\n let loc = Micheline.dummy_location in\n let* arg_type, storage_type, views, ctxt =\n if normalize_types then\n let*? arg_type, ctxt =\n unparse_parameter_ty ~loc ctxt arg_type ~entrypoints\n in\n let*? storage_type, ctxt = unparse_ty ~loc ctxt storage_type in\n let+ views, ctxt =\n Script_map.map_es_in_context\n (fun ctxt\n _name\n (Typed_view\n {input_ty; output_ty; kinstr = _; original_code_expr}) ->\n let*? input_ty, ctxt = unparse_ty ~loc ctxt input_ty in\n let*? output_ty, ctxt = unparse_ty ~loc ctxt output_ty in\n return ({input_ty; output_ty; view_code = original_code_expr}, ctxt))\n ctxt\n typed_views\n in\n (arg_type, storage_type, views, ctxt)\n else return (original_arg_type_expr, original_storage_type_expr, views, ctxt)\n in\n let* views, ctxt =\n Script_map.map_es_in_context\n (fun ctxt _name {input_ty; output_ty; view_code} ->\n let+ view_code, ctxt =\n unparse_code ctxt ~stack_depth:0 mode view_code\n in\n let view_code = Micheline.root view_code in\n ({input_ty; output_ty; view_code}, ctxt))\n ctxt\n views\n in\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 let open Lwt_result_syntax in\n let+ unparsed, ctxt = unparse_data ~stack_depth:0 ctxt mode ty data in\n pack_node unparsed ctxt\n\nlet hash_data ctxt ty data =\n let open Lwt_result_syntax in\n let* bytes, ctxt = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy in\n 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 let open Lwt_result_syntax in\n let* ctxt, init, id =\n match id with\n | Some id ->\n if Lazy_storage.IdSet.mem Big_map id ids_to_copy then\n let+ ctxt, duplicate = Big_map.fresh ~temporary ctxt in\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 let* ctxt, id = Big_map.fresh ~temporary ctxt in\n let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in\n let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost kt) in\n let*? kv, ctxt = unparse_ty ~loc:() ctxt value_type in\n let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost kv) in\n let key_type = Micheline.strip_locations kt in\n let value_type = Micheline.strip_locations kv in\n return (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id)\n in\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 let+ updates, ctxt =\n List.fold_left_es\n (fun (acc, ctxt) (key_hash, key, value) ->\n let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\n let* key, ctxt = unparse_comparable_data ctxt mode key_type key in\n let+ value, ctxt =\n match value with\n | None -> return (None, ctxt)\n | Some x ->\n let+ node, ctxt =\n unparse_data ~stack_depth:0 ctxt mode value_type x\n in\n (Some node, ctxt)\n in\n let diff_item = Big_map.{key; key_hash; value} in\n (diff_item :: acc, ctxt))\n ([], ctxt)\n (List.rev pairs)\n in\n (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 let open Lwt_result_syntax in\n let+ ctxt, init, id =\n match id with\n | Some id ->\n if Lazy_storage.IdSet.mem Sapling_state id ids_to_copy then\n let+ ctxt, duplicate = Sapling.fresh ~temporary ctxt in\n (ctxt, Lazy_storage.Copy {src = id}, duplicate)\n else return (ctxt, Lazy_storage.Existing, id)\n | None ->\n let+ ctxt, id = Sapling.fresh ~temporary ctxt in\n (ctxt, Lazy_storage.Alloc Sapling.{memo_size}, id)\n in\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 | Or_f :\n 'a has_lazy_storage * 'b has_lazy_storage\n -> ('a, 'b) or_ 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 | 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 | Or_t (l, r, _, _) -> aux2 (fun l r -> Or_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 let open Lwt_result_syntax in\n fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage ->\n let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\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 let+ diff, id, ctxt =\n diff_of_big_map ctxt mode ~temporary ~ids_to_copy map\n in\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 let+ diff, id, ctxt =\n diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state\n in\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 =\n Lazy_storage.IdSet.add Sapling_state id ids_to_copy\n in\n (ctxt, sapling_state, ids_to_copy, diff :: acc)\n | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) ->\n let* ctxt, xl, ids_to_copy, acc =\n aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl\n in\n let+ ctxt, xr, ids_to_copy, acc =\n aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr\n in\n (ctxt, (xl, xr), ids_to_copy, acc)\n | Or_f (has_lazy_storage, _), Or_t (ty, _, _, _), L x ->\n let+ ctxt, x, ids_to_copy, acc =\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n in\n (ctxt, L x, ids_to_copy, acc)\n | Or_f (_, has_lazy_storage), Or_t (_, ty, _, _), R x ->\n let+ ctxt, x, ids_to_copy, acc =\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n in\n (ctxt, R x, ids_to_copy, acc)\n | Option_f has_lazy_storage, Option_t (ty, _, _), Some x ->\n let+ ctxt, x, ids_to_copy, acc =\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n in\n (ctxt, Some x, ids_to_copy, acc)\n | List_f has_lazy_storage, List_t (ty, _), l ->\n let+ ctxt, l, ids_to_copy, acc =\n List.fold_left_es\n (fun (ctxt, l, ids_to_copy, acc) x ->\n let+ ctxt, x, ids_to_copy, acc =\n aux\n ctxt\n mode\n ~temporary\n ids_to_copy\n acc\n ty\n x\n ~has_lazy_storage\n in\n (ctxt, Script_list.cons x l, ids_to_copy, acc))\n (ctxt, Script_list.empty, ids_to_copy, acc)\n l.elements\n in\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 let+ ctxt, m, ids_to_copy, acc =\n List.fold_left_es\n (fun (ctxt, m, ids_to_copy, acc) (k, x) ->\n let+ ctxt, x, ids_to_copy, acc =\n aux\n ctxt\n mode\n ~temporary\n ids_to_copy\n acc\n ty\n x\n ~has_lazy_storage\n in\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 in\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 let open Result_syntax in\n fun ~f ~init ctxt ty x ~has_lazy_storage ->\n let* ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\n match (has_lazy_storage, ty, x) with\n | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} ->\n let* ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\n return (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt)\n | Sapling_state_f, Sapling_state_t _, {id = Some id; _} ->\n let* ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in\n return (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt)\n | False_f, _, _ -> return (Fold_lazy_storage.Ok init, ctxt)\n | Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _} ->\n return (Fold_lazy_storage.Ok init, ctxt)\n | Sapling_state_f, Sapling_state_t _, {id = None; _} ->\n return (Fold_lazy_storage.Ok init, ctxt)\n | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> (\n let* init, ctxt =\n fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl\n in\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 -> return (init, ctxt))\n | Or_f (has_lazy_storage, _), Or_t (ty, _, _, _), L x ->\n fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage\n | Or_f (_, has_lazy_storage), Or_t (_, ty, _, _), R x ->\n fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage\n | _, Option_t (_, _, _), None -> return (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)\n 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 -> return (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 :\n (('acc, error) Fold_lazy_storage.result * context) tzresult) ->\n let* init, ctxt = acc in\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 -> return (init, ctxt))\n m\n (return (Fold_lazy_storage.Ok init, ctxt))\n\nlet collect_lazy_storage ctxt ty x =\n let open Result_syntax in\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 let* ids, ctxt =\n fold_lazy_storage\n ~f:{f}\n ~init:no_lazy_storage_id\n ctxt\n ty\n x\n ~has_lazy_storage\n in\n match ids with Fold_lazy_storage.Ok ids -> return (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 open Lwt_result_syntax in\n let to_duplicate = Lazy_storage.IdSet.diff to_duplicate to_update in\n let+ ctxt, v, alive, diffs =\n extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v\n in\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_tickets\n ~allow_forged_lazy_storage_id ty t =\n parse_data\n ~unparse_code_rec\n ~elab_conf\n ~allow_forged_tickets\n ~allow_forged_lazy_storage_id\n ~stack_depth:0\n ctxt\n ty\n 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_tickets\n ~allow_forged_lazy_storage_id ty ~storage =\n parse_storage\n ~unparse_code_rec\n ~elab_conf\n ctxt\n ~allow_forged_tickets\n ~allow_forged_lazy_storage_id\n ty\n ~storage\n\nlet parse_script ~elab_conf ctxt ~allow_forged_tickets_in_storage\n ~allow_forged_lazy_storage_id_in_storage script =\n parse_script\n ~unparse_code_rec\n ~elab_conf\n ctxt\n ~allow_forged_tickets_in_storage\n ~allow_forged_lazy_storage_id_in_storage\n 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_tickets:false\n ~allow_forged_lazy_storage_id: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 let open Lwt_result_syntax in\n (* Constants need to be expanded or [unparse_code] may fail. *)\n let* ctxt, code =\n Global_constants_storage.expand ctxt (strip_locations code)\n in\n 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 toplevel =\n let open Lwt_result_syntax in\n let* ctxt, toplevel = Global_constants_storage.expand ctxt toplevel in\n Lwt.return @@ parse_toplevel ctxt 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 open Result_syntax in\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 let* id, ctxt =\n fold_lazy_storage ~f:{f} ~init:None ctxt ty x ~has_lazy_storage\n in\n match id with\n | Fold_lazy_storage.Ok (Some id) -> return (Some id, ctxt)\n | Fold_lazy_storage.Ok None | Fold_lazy_storage.Error -> return (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 let open Lwt_result_syntax in\n let+ Typechecked_code_internal {type_map; _}, ctxt =\n typecheck_code ~unparse_code_rec ~legacy ~show_types ctxt code\n in\n (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 let open Lwt_result_syntax in\n let* key_hash, ctxt = hash_comparable_data ctxt key_type key in\n match (Big_map_overlay.find key_hash diff.map, id) with\n | None, None -> return (false, ctxt)\n | None, Some id ->\n let+ ctxt, res = Alpha_context.Big_map.mem ctxt id key_hash in\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 let open Lwt_result_syntax in\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 let* ctxt, value_opt = Alpha_context.Big_map.get_opt ctxt id key in\n match value_opt with\n | None -> return (None, ctxt)\n | Some value ->\n let+ x, ctxt =\n parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged_tickets:true\n ~allow_forged_lazy_storage_id:true\n value_type\n (Micheline.root value)\n in\n (Some x, ctxt))\n\nlet get ctxt key (Big_map {key_type; _} as map) =\n let open Lwt_result_syntax in\n let* key_hash, ctxt = hash_comparable_data ctxt key_type key in\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 let open Lwt_result_syntax in\n let* key_hash, ctxt = hash_comparable_data ctxt key_type key in\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 let open Lwt_result_syntax in\n let* key_hash, ctxt = hash_comparable_data ctxt key_type key in\n let new_map = update_by_hash key_hash key value map in\n let* old_value, ctxt = get_by_hash ctxt key_hash map in\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 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" ;
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 let open Result_syntax in\n match Contract_hash.of_b58check_opt identifier with\n | Some addr -> return addr\n | None -> tzfail (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 let open Lwt_result_syntax in\n let* ctxt, script = Contract.get_script ctxt addr in\n match script with\n | None -> return (ctxt, None)\n | Some script ->\n Script_ir_translator.(\n let* ex_script, ctxt =\n parse_script\n ctxt\n script\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n in\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 let*? ctxt = Gas.consume ctxt cost in\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 let open Lwt_result_syntax in\n (*\n\n I/O, deserialization, and elaboration of contracts scripts\n are cached.\n\n *)\n let*? addr = contract_of_identifier identifier in\n let* (_ : context), result = load_and_elaborate ctxt addr in\n match result with\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, _) -> return (unparsed_script, ir_script)\nend\n\nmodule Cache = (val Cache.register_exn (module Client))\n\nlet find ctxt addr =\n let open Lwt_result_syntax in\n let identifier = identifier_of_contract addr in\n let* contract_opt = Cache.find ctxt identifier in\n match contract_opt with\n | Some (unparsed_script, ex_script) ->\n return (ctxt, identifier, Some (unparsed_script, ex_script))\n | None -> (\n let* ctxt, result = load_and_elaborate ctxt addr in\n match result with\n | None -> return (ctxt, identifier, None)\n | Some (unparsed_script, script_ir, size) ->\n let cached_value = (unparsed_script, script_ir) in\n let*? ctxt =\n Cache.update ctxt identifier (Some (cached_value, size))\n in\n return (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 let open Result_syntax in\n Cache.list_identifiers ctxt\n |> List.map_e @@ fun (identifier, age) ->\n let+ contract = contract_of_identifier identifier in\n (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" ;
} ;
{ 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 (* 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 types *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_implicit_account_parameters_type\"\n ~title:\"Unexpected implicit account parameters type\"\n ~description:\n \"An implicit account can only accept either a unit or a ticket value as \\\n a call parameter.\"\n (obj2\n (req \"loc\" Script.location_encoding)\n (req \"type\" Script.expr_encoding))\n (function\n | Unexpected_implicit_account_parameters_type (loc, ty) -> Some (loc, ty)\n | _ -> None)\n (fun (loc, ty) -> Unexpected_implicit_account_parameters_type (loc, ty)) ;\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_generated" ;
interface = None ;
implementation = "(* Do not edit this file manually.\n This file was automatically generated from benchmark models\n If you wish to update a function in this file,\n a. update the corresponding model, or\n b. move the function to another module and edit it there. *)\n\n[@@@warning \"-33\"]\n\nmodule S = Saturation_repr\nopen S.Syntax\n\n(* model tickets/COLLECT_TICKETS_STEP *)\n(* fun size -> max 10 (0. + (80. * size)) *)\nlet cost_COLLECT_TICKETS_STEP size =\n let size = S.safe_int size in\n S.max (S.safe_int 10) (size * S.safe_int 80)\n\n(* model tickets/COMPARE_CONTRACT *)\n(* max 10 10. *)\nlet cost_COMPARE_CONTRACT = S.safe_int 10\n\n(* model tickets/COMPARE_TICKET_HASH *)\n(* max 10 10. *)\nlet cost_COMPARE_TICKET_HASH = S.safe_int 10\n\n(* model tickets/TYPE_HAS_TICKETS *)\n(* fun size -> max 10 (10. + (6. * size)) *)\nlet cost_TYPE_HAS_TICKETS size = (size * S.safe_int 6) + S.safe_int 10\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 -> num_steps:int -> 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(* Copyright (c) 2023 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\ninclude Ticket_costs_generated\n\nmodule Constants = struct\n let cost_collect_tickets_step = cost_COLLECT_TICKETS_STEP 1\n\n let cost_compare_ticket_hash = cost_COMPARE_TICKET_HASH\n\n let cost_compare_key_contract = cost_COMPARE_CONTRACT\nend\n\nlet consume_gas_steps ctxt ~num_steps =\n if Compare.Int.(num_steps <= 0) then Ok ctxt\n else\n let gas = Gas.atomic_step_cost (cost_COLLECT_TICKETS_STEP num_steps) in\n Gas.consume ctxt gas\n\nlet has_tickets_of_ty_cost ty =\n cost_TYPE_HAS_TICKETS Script_typed_ir.(ty_size ty |> Type_size.to_int)\n\n(** Reusing the gas model from [Michelson_v1_gas.Cost_of.neg] *)\nlet negate_cost z =\n Michelson_v1_gas.Cost_of.Interpreter.neg (Script_int.of_zint z)\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 | Or_ht :\n 'a has_tickets * 'b has_tickets\n -> ('a, 'b) Script_typed_ir.or_ 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 [Or_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 | Pair_t (_, _, _, YesYes) -> (k [@ocaml.tailcall]) False_ht\n | Or_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 | 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 | Or_t (ty1, ty2, _, _) ->\n (has_tickets_of_pair [@ocaml.tailcall])\n ty1\n ty2\n ~pair:(fun ht1 ht2 -> Or_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 Result_syntax.tzfail 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 let open Result_syntax in\n let* ctxt = Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) in\n let+ ht = has_tickets_of_ty ty return in\n (ht, ctxt)\nend\n\nmodule Ticket_collection = struct\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 | Pair_t (_, _, _, YesYes) -> (k [@ocaml.tailcall]) ctxt acc\n | Or_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 let open Lwt_result_syntax in\n fun ctxt key_ty _set acc k ->\n let*? ctxt = Ticket_costs.consume_gas_steps ctxt ~num_steps:1 in\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 let open Lwt_result_syntax in\n fun ~include_lazy ctxt hty ty x acc k ->\n let open Script_typed_ir in\n let*? ctxt = Ticket_costs.consume_gas_steps ctxt ~num_steps:1 in\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 | Or_ht (htyl, htyr), Or_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 let open Lwt_result_syntax in\n fun ctxt ~include_lazy el_hty el_ty elements acc k ->\n let*? ctxt = Ticket_costs.consume_gas_steps ctxt ~num_steps:1 in\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 let open Lwt_result_syntax in\n fun ~include_lazy ctxt val_hty val_ty map acc k ->\n let (module M) = Script_map.get_module map in\n let*? ctxt = Ticket_costs.consume_gas_steps ctxt ~num_steps:1 in\n (* Pay gas for folding over the values *)\n let*? ctxt = Ticket_costs.consume_gas_steps ctxt ~num_steps:M.size in\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 let open Lwt_result_syntax in\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 let*? ctxt = Ticket_costs.consume_gas_steps ctxt ~num_steps:1 in\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])\n ctxt\n key_ty\n acc\n (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 let+ v, ctxt =\n Script_ir_translator.parse_data\n ~elab_conf:\n Script_ir_translator_config.(make ~legacy:true ())\n ctxt\n ~allow_forged_tickets:true\n ~allow_forged_lazy_storage_id:true\n value_type\n (Micheline.root exp)\n in\n (v :: values, ctxt)\n in\n let* ctxt, exps = Big_map.list_key_values ctxt id in\n let* values, ctxt = List.fold_left_es accum ([], ctxt) exps in\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 let open Result_syntax in\n let+ has_tickets, ctxt = Ticket_inspection.has_tickets_of_ty ctxt ty in\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 let open Lwt_result_syntax in\n match ht with\n | Ticket_inspection.False_ht -> return ([], ctxt)\n | _ ->\n let* value, ctxt =\n Script_ir_translator.parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged_tickets:true\n ~allow_forged_lazy_storage_id:true\n ty\n expr\n in\n tickets_of_value ctxt ~include_lazy has_tickets value\n\nlet ex_ticket_size ctxt (Ex_ticket (ty, ticket)) =\n (* type *)\n let open Lwt_result_syntax in\n let*? ty = Script_typed_ir.ticket_t Micheline.dummy_location ty in\n let*? ty', ctxt = Script_ir_unparser.unparse_ty ~loc:() ctxt ty in\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 let*? ctxt = Gas.consume ctxt ty_size_cost in\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 let*? ctxt = Gas.consume ctxt val_size_cost in\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 open Lwt_result_syntax in\n let loc = Micheline.dummy_location in\n let*? cont_ty_unstripped, ctxt =\n Script_ir_unparser.unparse_ty ~loc ctxt contents_type\n in\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 let*? ctxt =\n Gas.consume ctxt (Script.strip_annotations_cost cont_ty_unstripped)\n in\n let ty = Script.strip_annotations cont_ty_unstripped in\n let* contents, ctxt =\n Script_ir_unparser.unparse_comparable_data\n ctxt\n Script_ir_unparser.Optimized_legacy\n contents_type\n contents\n in\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 let open Result_syntax in\n let+ ctxt =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n in\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 let open Result_syntax in\n let* (token, amount), ctxt = token_and_amount ctxt ex_ticket in\n let+ ctxt = Gas.consume ctxt (Ticket_costs.negate_cost amount) in\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 let open Lwt_result_syntax in\n let* ex_tickets, ctxt =\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 in\n let*? result =\n let open Result_syntax in\n List.fold_left_e\n (fun (acc, ctxt) ticket ->\n let+ item, ctxt = get_token_and_amount ctxt ticket in\n (item :: acc, ctxt))\n (acc, ctxt)\n ex_tickets\n in\n return result\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 let open Lwt_result_syntax in\n let* old_value, ctxt =\n let*? val_opt, ctxt = Key_hash_map.find ctxt key_hash already_updated in\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 let+ ctxt, old_value = Big_map.get_opt ctxt big_map_id key_hash in\n (old_value, ctxt)\n in\n let* acc, 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 in\n let*? already_updated, ctxt =\n Key_hash_map.update\n ctxt\n key_hash\n (fun ctxt _ -> Ok (Some value, ctxt))\n already_updated\n in\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 let+ tickets, ctxt =\n collect_token_diffs_of_node_option\n ctxt\n ~get_token_and_amount:token_and_amount\n value\n acc\n in\n (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 let open Lwt_result_syntax in\n let*? Script_typed_ir.Ex_ty value_type, ctxt =\n parse_value_type ctxt value_type\n in\n let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt value_type in\n let+ acc, _already_updated, 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 in\n (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 let open Lwt_result_syntax in\n let*? ctxt =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n in\n let* ctxt, key_val_tys = Big_map.exists ctxt big_map_id in\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 let*? Script_typed_ir.Ex_ty value_type, ctxt =\n parse_value_type ctxt value_ty\n in\n let*? has_tickets, ctxt =\n Ticket_scanner.type_has_tickets ctxt value_type\n in\n (* Iterate over big-map items. *)\n let* ctxt, exprs = Big_map.list_key_values ctxt big_map_id in\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 let open Lwt_result_syntax in\n let*? ctxt =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n in\n let* ctxt, key_val_opt = Big_map.exists ctxt big_map_id in\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 let open Lwt_result_syntax in\n let*? ctxt =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n in\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 let* acc, ctxt =\n collect_token_diffs_of_big_map\n ctxt\n ~get_token_and_amount:token_and_amount\n src\n acc\n in\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 = "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 let open Result_syntax 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 -> tzfail Alpha_context.Zk_rollup.Errors.Wrong_deposit_parameters\n | Some zkru_operation ->\n return\n {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); zkru_operation})\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_context f key ctxt val_opt =\n let open Result_syntax in\n let+ val_opt, ctxt =\n match val_opt with\n | Some (_tkn, value) -> f ctxt (Some value)\n | None -> f ctxt None\n in\n (Option.map (fun v -> (key, v)) val_opt, ctxt)\n\nlet update ctxt key f m =\n let open Lwt_result_syntax in\n let* key_hash, ctxt = key_of_ticket_token ctxt key in\n Ticket_token_map.update ctxt key_hash (update_context f key) 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 let open Lwt_result_syntax in\n let* key_hash, ctxt = key_of_ticket_token ctxt ticket_token in\n let*? val_opt, ctxt = Ticket_token_map.find ctxt key_hash map in\n return (Option.map snd val_opt, ctxt)\n\nlet lift_merge_overlap merge_overlap ctxt (tkn1, v1) (_tkn2, v2) =\n let open Result_syntax in\n let+ v, ctxt = merge_overlap ctxt v1 v2 in\n ((tkn1, v), ctxt)\n\nlet of_list ctxt ~merge_overlap token_values =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (map, ctxt) (token, value) ->\n let* key_hash, ctxt = key_of_ticket_token ctxt token in\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 let open Result_syntax in\n let+ x, ctxt =\n lift_merge_overlap merge_overlap ctxt old (token, value)\n in\n (Some x, ctxt))\n map))\n (Ticket_token_map.empty, ctxt)\n token_values\n\nlet map_e ctxt f =\n let open Result_syntax in\n Ticket_token_map.map_e ctxt (fun ctxt _key (tkn, value) ->\n let+ new_value, ctxt = f ctxt tkn value in\n ((tkn, new_value), ctxt))\n\nlet to_list ctxt map =\n let open Result_syntax in\n let* list, ctxt = Ticket_token_map.to_list ctxt map in\n (* Consume gas for traversing the list again and remove the key-hash. *)\n let+ ctxt =\n Gas.consume\n ctxt\n (Carbonated_map_costs.fold_cost ~size:(Ticket_token_map.size map))\n in\n (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 *)\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 let open Result_syntax in\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 return (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 let+ ctxt =\n Gas.consume\n ctxt\n Script_int.(\n Ticket_costs.add_int_cost\n (prev_amount :> n num)\n (amount :> n num))\n in\n (Some (Ticket_amount.add prev_amount amount), ctxt)\n | None -> return (Some amount, ctxt)\n in\n let+ destination_map, ctxt =\n Destination_map.update ctxt destination update destination_map\n in\n (Some destination_map, ctxt))\n map\nend\n\nlet tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters =\n let open Lwt_result_syntax in\n let*? has_tickets, ctxt =\n Ticket_scanner.type_has_tickets ctxt parameters_ty\n in\n let* tickets, ctxt =\n Ticket_scanner.tickets_of_value\n ~include_lazy:true\n ctxt\n has_tickets\n parameters\n in\n 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 let open Lwt_result_syntax in\n let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt storage_type in\n let+ tickets, ctxt =\n Ticket_scanner.tickets_of_value ctxt ~include_lazy:true has_tickets storage\n in\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 {sender = _; 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_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 let open Lwt_result_syntax in\n List.fold_left_es\n (fun (token_map, ctxt) op ->\n let* res, ctxt = tickets_of_operation ctxt op in\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 let open Lwt_result_syntax in\n let* token_map, ctxt = ticket_token_map_of_operations ctxt operations in\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 let open Result_syntax in\n let* total_amount, ctxt =\n Destination_map.fold_e\n ctxt\n (fun ctxt total_amount _destination (amount : Ticket_amount.t) ->\n let+ ctxt =\n Gas.consume\n ctxt\n Script_int.(\n Ticket_costs.add_int_cost total_amount (amount :> n num))\n in\n (Script_int.(add_n total_amount (amount :> n num)), ctxt))\n Script_int.zero_n\n destination_map\n in\n let+ destinations, ctxt = Destination_map.to_list ctxt destination_map in\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 [sender] 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 sender: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 ~sender_hash ~dst_hash qty] updates\n the table of tickets moves [qty] units of a given ticket from a\n sender to a destination, as encoded by [sender_hash] and [dst_hash].\n\n Consistency between [sender_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 sender_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 ~sender ~dst ex_token qty] updates the table of\n tickets moves [qty] units of [ex_token] from [sender] to [dst], as\n encoded by [sender_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 sender: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\n(** [transfer_tickets_in_parameters ctxt param param_ty ~source ~dst]\n Scans the [param] for tickets and transfers ownership of those tickets\n from [source] to [dst] by updating the ticket table. The function returns\n the updated context, the ticket receipt, and the number of newly allocated\n bytes for the ticket table. *)\nval transfer_tickets_in_parameters :\n context ->\n 'a ->\n ('a, 'b) Script_typed_ir.ty ->\n source:Destination.t ->\n dst:Destination.t ->\n (context * Ticket_receipt.t * 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 let open Lwt_result_syntax in\n let*? ty, ctxt =\n Script.force_decode_in_context ~consume_deserialization_gas ctxt ty\n in\n let*? contents, ctxt =\n Script.force_decode_in_context ~consume_deserialization_gas ctxt contents\n in\n let*? Ex_comparable_ty contents_type, ctxt =\n Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty)\n in\n let* contents, ctxt =\n Script_ir_translator.parse_comparable_data\n ctxt\n contents_type\n (Micheline.root contents)\n in\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 ~sender ~destination ~entrypoint ~amount ctxt =\n let open Lwt_result_syntax in\n let* ( ctxt,\n (Ticket_token.Ex_token {contents; contents_type; ticketer} as token) )\n =\n parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt\n in\n let*? ticket_ty =\n Script_typed_ir.ticket_t Micheline.dummy_location contents_type\n in\n let ticket = Script_typed_ir.{ticketer; contents; amount} in\n let* unparsed_parameters, ctxt =\n Script_ir_translator.unparse_data ctxt Optimized ticket_ty ticket\n in\n let*? ctxt, nonce = fresh_internal_nonce ctxt in\n let op =\n Script_typed_ir.Internal_operation\n {\n sender;\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 ~sender_hash ~dst_hash\n (qty : Ticket_amount.t) =\n let qty = Script_int.(to_zint (qty :> n num)) in\n let open Lwt_result_syntax in\n let* sender_storage_diff, ctxt =\n Ticket_balance.adjust_balance ctxt sender_hash ~delta:(Z.neg qty)\n in\n let* dst_storage_diff, ctxt =\n Ticket_balance.adjust_balance ctxt dst_hash ~delta:qty\n in\n let* diff, ctxt =\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:(Z.add sender_storage_diff dst_storage_diff)\n in\n return (ctxt, diff)\n\nlet transfer_ticket ctxt ~sender ~dst ex_token qty =\n let open Lwt_result_syntax in\n let* sender_hash, ctxt =\n Ticket_balance_key.of_ex_token ctxt ~owner:sender ex_token\n in\n let* dst_hash, ctxt =\n Ticket_balance_key.of_ex_token ctxt ~owner:dst ex_token\n in\n transfer_ticket_with_hashes ctxt ~sender_hash ~dst_hash qty\n\nlet transfer_tickets_in_parameters ctxt parameter parameter_ty ~source ~dst =\n let open Lwt_result_syntax in\n let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt parameter_ty in\n let* tickets, ctxt =\n Ticket_scanner.tickets_of_value\n ~include_lazy:true\n ctxt\n has_tickets\n parameter\n in\n let* ctxt, ticket_receipt, paid_storage_diff =\n List.fold_left_es\n (fun (ctxt, ticket_receipt_acc, paid_storage_diff_acc) ticket ->\n let ticket_token, amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket ticket\n in\n let* ctxt, paid_storage_diff =\n transfer_ticket ctxt ~sender:source ~dst ticket_token amount\n in\n let* ticket_token, ctxt =\n Ticket_token_unparser.unparse ctxt ticket_token\n in\n let amount = Script_int.(to_zint (amount :> n num)) in\n let ticket_receipt_item =\n Ticket_receipt.\n {\n ticket_token;\n updates = [{account = source; amount = Z.neg amount}];\n (* We only handle negation from the [source] in this receipt.\n The addition to [dst] will be taken into account in the receipts\n generated from the subsequent contract execution. *)\n }\n in\n return\n ( ctxt,\n ticket_receipt_item :: ticket_receipt_acc,\n Z.add paid_storage_diff_acc paid_storage_diff ))\n (ctxt, [], Z.zero)\n tickets\n in\n return (ctxt, ticket_receipt, paid_storage_diff)\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 | IPush _ -> Interp_costs.push\n | IUnit _ -> Interp_costs.unit\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 (_, _, map, _, _) -> Interp_costs.Control.map_enter_body map\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 None -> return_none | 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) continuation ->\n a * s * (e, z, b, t) continuation =\n fun w accu stack ks ->\n match w with\n | KPrefix (_loc, ty, w) ->\n let ks = KUndip (accu, Some ty, ks) in\n let accu, stack = stack in\n kundip w accu stack ks\n | KRest -> (accu, stack, ks)\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 open Lwt_result_syntax in\n let loc = Micheline.dummy_location in\n let ctxt = update_context gas ctxt in\n let*? ty_expr, ctxt = Script_ir_unparser.unparse_ty ~loc ctxt capture_ty in\n let* const_expr, ctxt = unparse_data ctxt Optimized capture_ty capture in\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 let*? arg_ty_expr, ctxt =\n Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty\n in\n let*? ret_ty_expr, ctxt =\n Script_ir_unparser.unparse_ty ~loc ctxt ret_ty\n 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 (* 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 IPush\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 IPush\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 let* lam', ctxt = lam' in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n return (lam', ctxt, gas)\n\nlet make_transaction_to_sc_rollup ctxt ~destination ~amount ~entrypoint\n ~parameters_ty ~parameters =\n let open Lwt_result_syntax in\n let*? () =\n error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount\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 let*? () =\n error_unless (Entrypoint.is_default entrypoint) Rollup_invalid_entrypoint\n in\n let+ unparsed_parameters, ctxt =\n unparse_data ctxt Optimized parameters_ty parameters\n in\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 open Lwt_result_syntax in\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 let* unparsed_data, ctxt =\n unparse_data ctxt Optimized event_type event_data\n in\n let*? ctxt, nonce = fresh_internal_nonce ctxt in\n let operation = Event {ty = unparsed_ty; tag; unparsed_data} in\n let iop =\n {\n sender = 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 let open Lwt_result_syntax in\n let*? () =\n error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount\n in\n let+ unparsed_parameters, ctxt =\n unparse_data ctxt Optimized parameters_ty parameters\n in\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 open Lwt_result_syntax in\n let ctxt = update_context gas ctxt in\n let* operation, lazy_storage_diff, ctxt =\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 let* unparsed_ticket, ctxt =\n unparse_data ctxt Optimized ticket_ty parameters\n in\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 let*? to_duplicate, ctxt =\n collect_lazy_storage ctxt parameters_ty parameters\n in\n let to_update = no_lazy_storage_id in\n let* parameters, lazy_storage_diff, ctxt =\n extract_lazy_storage_diff\n ctxt\n Optimized\n parameters_ty\n parameters\n ~to_duplicate\n ~to_update\n ~temporary:true\n in\n let+ unparsed_parameters, ctxt =\n unparse_data ctxt Optimized parameters_ty parameters\n in\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_sc_rollup\n {arg_ty = parameters_ty; sc_rollup = destination; entrypoint} ->\n let+ operation, ctxt =\n make_transaction_to_sc_rollup\n ctxt\n ~destination\n ~amount\n ~entrypoint\n ~parameters_ty\n ~parameters\n in\n (operation, None, ctxt)\n | Typed_zk_rollup {arg_ty = parameters_ty; zk_rollup = destination} ->\n let+ operation, ctxt =\n make_transaction_to_zk_rollup\n ctxt\n ~destination\n ~amount\n ~parameters_ty\n ~parameters\n in\n (operation, None, ctxt)\n in\n let*? ctxt, nonce = fresh_internal_nonce ctxt in\n let iop =\n {\n sender = 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 open Lwt_result_syntax in\n let ctxt = update_context gas ctxt in\n let*? to_duplicate, ctxt = collect_lazy_storage ctxt storage_type init in\n let to_update = no_lazy_storage_id in\n let* init, lazy_storage_diff, ctxt =\n extract_lazy_storage_diff\n ctxt\n Optimized\n storage_type\n init\n ~to_duplicate\n ~to_update\n ~temporary:true\n in\n let* unparsed_storage, ctxt = unparse_data ctxt Optimized storage_type init in\n let*? ctxt, preorigination =\n Contract.fresh_contract_from_current_nonce ctxt\n in\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 let*? ctxt, nonce = fresh_internal_nonce ctxt in\n let sender = Destination.Contract (Contract.Originated sc.self) in\n let piop = Internal_operation {sender; 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 let open Lwt_result_syntax in\n let*? ctxt =\n Gas.consume\n ctxt\n (Script.deserialization_cost_estimated_from_bytes (Bytes.length bytes))\n in\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 let*? ctxt = Gas.consume ctxt (Interp_costs.unpack_failed str) in\n return (None, ctxt)\n | Some expr -> (\n let*! value_opt =\n parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged_tickets:false\n ~allow_forged_lazy_storage_id:false\n ty\n (Micheline.root expr)\n in\n match value_opt with\n | Ok (value, ctxt) -> return (Some value, ctxt)\n | Error _ignored ->\n let*? ctxt = Gas.consume ctxt (Interp_costs.unpack_failed str) in\n return (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) or_ ->\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 sender : 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 ([sender], [payer], [amount], and [chain_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 sender : 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 \"While interpreting a Michelson script, an overflow was detected\"\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 let open Lwt_result_syntax in\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 ->\n let* log = get_log logger in\n tzfail (Overflow (loc, log))\n | Some y ->\n let*? res = Tez.(x *? y) in\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 let open Lwt_result_syntax in\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 ->\n let* log = get_log logger in\n tzfail (Overflow (loc, log))\n | Some y ->\n let*? res = Tez.(x *? y) in\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 let open Lwt_result_syntax in\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 ->\n let* log = get_log logger in\n 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 let open Lwt_result_syntax in\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 ->\n let* log = get_log logger in\n 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 let open Lwt_result_syntax in\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 ->\n let* log = get_log logger in\n tzfail (Overflow (loc, log))\n | Some res -> (step [@ocaml.tailcall]) g gas k ks res stack\n\n and ifailwith : ifailwith_type =\n let open Lwt_result_syntax in\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 let* v, _ctxt =\n trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)\n in\n let* log = get_log logger in\n 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 let open Lwt_result_syntax in\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 _) | Sc_rollup _ | Zk_rollup _ ->\n (return_none [@ocaml.tailcall]) ctxt\n | Contract (Originated contract_hash as c) -> (\n let* ctxt, script_opt = Contract.get_script ctxt contract_hash in\n match script_opt with\n | None -> (return_none [@ocaml.tailcall]) ctxt\n | Some script -> (\n let* Ex_script (Script {storage; storage_type; views; _}), ctxt =\n parse_script\n ~elab_conf:legacy\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n ctxt\n script\n in\n let*? ctxt =\n Gas.consume ctxt (Interp_costs.view_get name views)\n in\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 let* ( Typed_view\n {\n input_ty = input_ty';\n output_ty = output_ty';\n kinstr;\n original_code_expr = _;\n },\n ctxt ) =\n trace_eval\n (fun () ->\n Script_tc_errors.Ill_typed_contract\n (Micheline.strip_locations view.view_code, []))\n view_result\n in\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 let*? eq, ctxt = Gas_monad.run ctxt io_ty in\n match eq with\n | Error Inconsistent_types_fast ->\n (return_none [@ocaml.tailcall]) ctxt\n | Ok (Eq, Eq) ->\n let kcons =\n KCons (ICons_some (kinstr_location k, k), ks)\n in\n let* ctxt, balance =\n Contract.get_balance_carbonated ctxt c\n in\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 sender =\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 let open Lwt_result_syntax in\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 | IPush (_, _ty, v, k) ->\n (step [@ocaml.tailcall]) g gas k ks v (accu, stack)\n | IUnit (_, k) -> (step [@ocaml.tailcall]) g gas k ks () (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 (* ors *)\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 let* res, ctxt, gas =\n use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.mem ctxt key map\n in\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 let* res, ctxt, gas =\n use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.get ctxt key map\n in\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 let* big_map, ctxt, gas =\n use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.update ctxt key maybe_value map\n in\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 let* (v', map'), ctxt, gas =\n use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.get_and_update ctxt key v map\n in\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 let*? gas =\n consume gas (Interp_costs.concat_string total_length)\n in\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\n Compare.Z.(offset < s_length && Z.add offset length <= s_length)\n then\n let s =\n Script_string.sub s (Z.to_int offset) (Z.to_int length)\n 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 let*? gas =\n consume gas (Interp_costs.concat_string total_length)\n in\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\n 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 let*? res = Tez.(x +? y) in\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 let*? res = Tez.(x -? y) in\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 let* lam', ctxt, gas = apply ctxt gas capture_ty capture lam in\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 let* bytes, ctxt, gas =\n use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_ir_translator.pack_data ctxt ty value\n in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack\n | IUnpack (_, ty, k) ->\n let bytes = accu in\n let* opt, ctxt, gas =\n use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n unpack ctxt ~ty ~bytes\n in\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\n 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 let* ctxt, maybe_contract =\n Script_ir_translator.parse_contract_for_script\n ctxt\n loc\n t\n addr.destination\n ~entrypoint\n in\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 let* accu, ctxt, gas =\n transfer (ctxt, sc) gas amount loc typed_contract p\n in\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 let* res, contract, ctxt, gas =\n create_contract g gas storage_type code delegate credit init\n in\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 let*? ctxt, nonce = fresh_internal_nonce ctxt in\n let piop =\n Internal_operation\n {\n sender = 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) ->\n (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.sender 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, ks = kundip n' accu stack (KCons (k, 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 let* ctxt, balance_state_opt =\n Sapling.verify_update ctxt state transaction anti_replay\n in\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 let* ctxt, balance_state_opt =\n Sapling.Legacy.verify_update ctxt state transaction anti_replay\n in\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 let* ctxt, power = Vote.get_voting_power ctxt key_hash in\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 let* ctxt, power = Vote.get_total_voting_power ctxt in\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 -> None\n | Some time -> (\n match Script_timelock.open_chest chest chest_key ~time with\n | Correct bytes -> Some bytes\n | Bogus_opening -> None)\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 let* accu, ctxt, gas =\n emit_event\n (ctxt, sc)\n gas\n ~event_type\n ~unparsed_ty\n ~tag\n ~event_data\n in\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 open Lwt_result_syntax in\n let gas, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in\n let* accu, stack, ctxt, gas =\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 in\n return (accu, stack, update_context gas ctxt)\n\nlet interp logger g lam arg =\n let open Lwt_result_syntax in\n match lam with\n | LamRec (code, _) ->\n let+ ret, (EmptyCell, EmptyCell), ctxt =\n step_descr ~log_now:true logger g code arg (lam, (EmptyCell, EmptyCell))\n in\n (ret, ctxt)\n | Lam (code, _) ->\n let+ ret, (EmptyCell, EmptyCell), ctxt =\n step_descr ~log_now:true logger g code arg (EmptyCell, EmptyCell)\n in\n (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 let open Lwt_result_syntax in\n let* entrypoint_arg, ctxt =\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_tickets:internal\n ~allow_forged_lazy_storage_id:internal\n entrypoint_ty\n arg\n | Typed_arg (loc, parsed_arg_ty, parsed_arg) ->\n let*? res, ctxt =\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 in\n let*? Eq = res in\n let parsed_arg : a = parsed_arg in\n return (parsed_arg, ctxt)\n in\n 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 open Lwt_result_syntax in\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 let* ( 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 match cached_script with\n | None ->\n parse_script\n ctxt\n unparsed_script\n ~elab_conf\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n | Some ex_script -> return (ex_script, ctxt)\n in\n let*? r, ctxt =\n Gas_monad.run\n ctxt\n (find_entrypoint\n ~error_details:(Informative ())\n arg_type\n entrypoints\n entrypoint)\n in\n let self_contract = Contract.Originated step_constants.self in\n let*? (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) =\n record_trace (Bad_contract_parameter self_contract) r\n in\n let* arg, ctxt =\n trace\n (Bad_contract_parameter self_contract)\n (lift_execution_arg ctxt ~internal entrypoint_ty construct arg)\n in\n let*? to_duplicate, ctxt =\n Script_ir_translator.collect_lazy_storage ctxt arg_type arg\n in\n let*? to_update, ctxt =\n Script_ir_translator.collect_lazy_storage ctxt storage_type old_storage\n in\n let* (ops, new_storage), ctxt =\n trace\n (Runtime_contract_error step_constants.self)\n (interp logger (ctxt, step_constants) code (arg, old_storage))\n in\n let* storage, lazy_storage_diff, 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 in\n let* unparsed_storage, ctxt =\n trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)\n in\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 let*? arg_type_has_tickets, ctxt =\n Ticket_scanner.type_has_tickets ctxt arg_type\n in\n let*? storage_type_has_tickets, ctxt =\n Ticket_scanner.type_has_tickets ctxt storage_type\n in\n (* Collect the ticket diffs *)\n let* ticket_diffs, ticket_receipt, ctxt =\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 in\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 let*? ctxt = Gas.consume ctxt cost in\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 open Lwt_result_syntax in\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 let* accu, stack, ctxt, gas =\n step (outdated_ctxt, step_constants) gas kinstr KNil accu stack\n in\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 | Whitelist_update of Sc_rollup.Whitelist.t option\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_transactions_untyped t] encodes the outbox transaction\n batch [t] in binary format using the untyped outbox message\n representation. *)\n val serialize_outbox_transactions_untyped :\n transaction list -> Sc_rollup.Outbox.Message.serialized tzresult\n\n (** [serialize_output_transactions_typed t] encodes the outbox\n transaction batch [t] in binary format using the typed outbox message\n representation. *)\n val serialize_outbox_transactions_typed :\n transaction list -> 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 =\n | Atomic_transaction_batch of atomic_transaction_batch\n | Whitelist_update of Sc_rollup.Whitelist.t option\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 make_transaction ctxt ~parameters_ty ~unparsed_parameters ~destination\n ~entrypoint =\n let open Lwt_result_syntax in\n (* Parse the parameters according to the given 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_tickets:true\n ~allow_forged_lazy_storage_id:false\n parameters_ty\n (Micheline.root unparsed_parameters)\n in\n ( ctxt,\n Transaction\n {destination; entrypoint; parameters_ty; parameters; unparsed_parameters}\n )\n\nlet internal_untyped_transaction ctxt\n ({unparsed_parameters; destination; entrypoint} :\n Sc_rollup.Outbox.Message.transaction) =\n let open Lwt_result_syntax in\n let* Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}), ctxt\n =\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 make_transaction\n ctxt\n ~parameters_ty\n ~unparsed_parameters\n ~destination\n ~entrypoint\n\nlet internal_typed_transaction ctxt\n ({unparsed_parameters; unparsed_ty; destination; entrypoint} :\n Sc_rollup.Outbox.Message.typed_transaction) =\n let open Lwt_result_syntax in\n (* Parse the parameters type according to the type. *)\n let*? Ex_ty parameters_ty, ctxt =\n Script_ir_translator.parse_any_ty\n ctxt\n ~legacy:false\n (Micheline.root unparsed_ty)\n in\n make_transaction\n ctxt\n ~parameters_ty\n ~unparsed_parameters\n ~destination\n ~entrypoint\n\nlet outbox_message_of_outbox_message_repr ctxt transactions =\n let open Lwt_result_syntax in\n match transactions with\n | Sc_rollup.Outbox.Message.Atomic_transaction_batch {transactions} ->\n let* ctxt, transactions =\n List.fold_left_map_es internal_untyped_transaction ctxt transactions\n in\n return (Atomic_transaction_batch {transactions}, ctxt)\n | Sc_rollup.Outbox.Message.Atomic_transaction_batch_typed {transactions} ->\n let* ctxt, transactions =\n List.fold_left_map_es internal_typed_transaction ctxt transactions\n in\n return (Atomic_transaction_batch {transactions}, ctxt)\n | Sc_rollup.Outbox.Message.Whitelist_update whitelist_opt ->\n return (Whitelist_update whitelist_opt, 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_transactions_untyped transactions =\n let open Result_syntax in\n let of_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 of_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 serialize_outbox_transactions_typed transactions =\n let open Result_syntax in\n let of_internal_transaction\n (Transaction\n {\n destination;\n entrypoint;\n parameters_ty;\n parameters = _;\n unparsed_parameters;\n }) =\n let unparsed_ty =\n Script_ir_unparser.serialize_ty_for_error parameters_ty\n in\n return\n {\n Sc_rollup.Outbox.Message.unparsed_parameters;\n unparsed_ty;\n destination;\n entrypoint;\n }\n in\n let* transactions = List.map_e of_internal_transaction transactions in\n let output_message_internal =\n Sc_rollup.Outbox.Message.Atomic_transaction_batch_typed {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 whitelist_update : Sc_rollup.Whitelist.update option;\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 ?whitelist context ~kind ~boot_sector ~parameters_ty] adds a new rollup\n running in a given [kind] initialized with a [boot_sector] and to accept\n smart contract calls of type [parameters_ty]. *)\nval originate :\n ?whitelist:Sc_rollup.Whitelist.t ->\n context ->\n kind:Sc_rollup.Kind.t ->\n boot_sector:string ->\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(** [validate_untyped_parameters_ty ctxt script] parses the type and check\n that the entrypoints are well-formed. *)\nval validate_untyped_parameters_ty : context -> Script.expr -> context tzresult\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 ('a, 'b) error_container = {given : 'a; last_update : 'b}\n\ntype outdated_whitelist_update =\n | Outdated_message_index of\n (Z.t, Sc_rollup.Whitelist.last_whitelist_update) error_container\n | Outdated_outbox_level of\n (Raw_level.t, Sc_rollup.Whitelist.last_whitelist_update) error_container\n\nlet outdated_whitelist_update_encoding =\n Data_encoding.(\n union\n [\n case\n ~title:\"outdated_message_index\"\n (Tag 0)\n (obj2\n (req \"message_index\" n)\n (req\n \"last_whitelist_update\"\n Sc_rollup.Whitelist.last_whitelist_update_encoding))\n (function\n | Outdated_message_index {given; last_update} ->\n Some (given, last_update)\n | _ -> None)\n (fun (given, last_update) ->\n Outdated_message_index {given; last_update});\n case\n ~title:\"outdated_outbox_level\"\n (Tag 1)\n (obj2\n (req \"outbox_level\" Raw_level.encoding)\n (req\n \"last_whitelist_update\"\n Sc_rollup.Whitelist.last_whitelist_update_encoding))\n (function\n | Outdated_outbox_level {given; last_update} ->\n Some (given, last_update)\n | _ -> None)\n (fun (given, last_update) ->\n Outdated_outbox_level {given; last_update});\n ])\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 | (* Permanent *)\n Sc_rollup_outdated_whitelist_update of\n outdated_whitelist_update\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 whitelist_update : Sc_rollup.Whitelist.update option;\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 let description = \"Outdated whitelist update\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_outdated_whitelist_update\"\n ~title:description\n ~description\n ~pp:\n (fun ppf -> function\n | Outdated_message_index {given; last_update} ->\n Format.fprintf\n ppf\n \"%s: got message index %a at outbox level %a, while the lastest \\\n whitelist update occurred with message index %a.\"\n description\n Z.pp_print\n given\n Z.pp_print\n last_update.message_index\n Raw_level.pp\n last_update.outbox_level\n | Outdated_outbox_level {given; last_update} ->\n Format.fprintf\n ppf\n \"%s: got outbox level %a, while the current outbox level is %a \\\n with message index %a.\"\n description\n Raw_level.pp\n given\n Raw_level.pp\n last_update.outbox_level\n Z.pp_print\n last_update.message_index)\n outdated_whitelist_update_encoding\n (function Sc_rollup_outdated_whitelist_update e -> Some e | _ -> None)\n (fun e -> Sc_rollup_outdated_whitelist_update e)\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 let open Result_syntax in\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 tzfail 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 | Chain_id_t -> (k [@ocaml.tailcall]) ()\n (* Valid collection types. *)\n | Ticket_t (ty, _) ->\n (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 | Or_t (ty1, ty2, _, _) ->\n let entrypoints_l, entrypoints_r =\n match nested_entrypoints with\n | Entrypoints_None -> (no_entrypoints, no_entrypoints)\n | Entrypoints_Or {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 -> tzfail Sc_rollup_invalid_parameters_type\n | Big_map_t (_key_ty, _val_ty, _) ->\n tzfail Sc_rollup_invalid_parameters_type\n | Contract_t _ -> tzfail Sc_rollup_invalid_parameters_type\n | Sapling_transaction_t _ -> tzfail Sc_rollup_invalid_parameters_type\n | Sapling_transaction_deprecated_t _ ->\n tzfail Sc_rollup_invalid_parameters_type\n | Sapling_state_t _ -> tzfail Sc_rollup_invalid_parameters_type\n | Operation_t -> tzfail Sc_rollup_invalid_parameters_type\n | Chest_t -> tzfail Sc_rollup_invalid_parameters_type\n | Chest_key_t -> tzfail Sc_rollup_invalid_parameters_type\n | Lambda_t (_, _, _) -> tzfail 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 let open Result_syntax in\n fun ctxt parameters_ty entrypoints ->\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 return 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 originate ?whitelist ctxt ~kind ~boot_sector ~parameters_ty =\n let open Lwt_result_syntax 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 boot_sector_size_in_bytes = String.length boot_sector in\n let*? ctxt =\n match kind with\n | Sc_rollup.Kind.Wasm_2_0_0 | Example_arith | Riscv ->\n (*\n\n We do not really care about the precision of the gas model\n when it comes to the [Example_arith] PVM, so we use the\n WASM PVM model for both cases.\n\n As you can convince yourself by code inspection, the cost\n of [Sc_rollup.genesis_state_hash_of] is dominated by the\n installation of the boot sector.\n\n *)\n Gas.consume ctxt\n @@ Sc_rollup_costs.cost_install_boot_sector_in_wasm_pvm\n ~boot_sector_size_in_bytes\n in\n let*! genesis_hash = Sc_rollup.genesis_state_hash_of kind ~boot_sector 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 ?whitelist 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 {sender = Destination.Sc_rollup rollup; operation; nonce},\n 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* ctxt, storage_diff =\n Ticket_transfer.transfer_ticket\n ctxt\n ~sender:source_destination\n ~dst:target_destination\n ticket_token\n Ticket_amount.((amount :> t))\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 -> Result_syntax.tzfail Sc_rollup_invalid_output_proof\n 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* output = PVM.verify_output_proof output_proof 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_transaction ctxt ~transactions ~rollup =\n let open Lwt_result_syntax 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 (* 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 (Z.zero, 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\n ( {\n paid_storage_size_diff;\n ticket_receipt;\n operations;\n whitelist_update = None;\n },\n ctxt )\n\nlet execute_outbox_message_whitelist_update (ctxt : t) ~rollup ~whitelist\n ~outbox_level ~message_index =\n let open Lwt_result_syntax in\n let* ctxt, is_private = Sc_rollup.Whitelist.is_private ctxt rollup in\n if is_private then\n match whitelist with\n | Some whitelist ->\n (* The whitelist update fails with an empty list. *)\n let*? () =\n error_when\n (List.is_empty whitelist)\n Sc_rollup_errors.Sc_rollup_empty_whitelist\n in\n let* ( ctxt,\n (Sc_rollup.Whitelist.\n {\n message_index = latest_message_index;\n outbox_level = latest_outbox_level;\n } as last_update) ) =\n Sc_rollup.Whitelist.get_last_whitelist_update ctxt rollup\n in\n (* Do not apply whitelist update if a previous whitelist update\n occurred with a greater message index for a given outbox level,\n or with a greater outbox level. *)\n let* () =\n fail_when\n (Raw_level.(latest_outbox_level = outbox_level)\n && Compare.Z.(latest_message_index >= message_index))\n (Sc_rollup_outdated_whitelist_update\n (Outdated_message_index {given = message_index; last_update}))\n in\n let* () =\n fail_when\n Raw_level.(outbox_level < latest_outbox_level)\n (Sc_rollup_outdated_whitelist_update\n (Outdated_outbox_level {given = outbox_level; last_update}))\n in\n let* ctxt, new_storage_size =\n Sc_rollup.Whitelist.replace ctxt rollup ~whitelist\n in\n let* ctxt, size_diff =\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/6186\n Do not consider storage diffs for small updates to the storage. *)\n Sc_rollup.Whitelist.set_last_whitelist_update\n ctxt\n rollup\n {outbox_level; message_index}\n in\n let* ctxt, paid_storage_size_diff =\n Sc_rollup.Whitelist.adjust_storage_space ctxt rollup ~new_storage_size\n in\n return\n ( {\n paid_storage_size_diff = Z.add paid_storage_size_diff size_diff;\n ticket_receipt = [];\n operations = [];\n whitelist_update = Some (Private whitelist);\n },\n ctxt )\n | None ->\n let* ctxt, _freed_size = Sc_rollup.Whitelist.make_public ctxt rollup in\n return\n ( {\n paid_storage_size_diff = Z.zero;\n ticket_receipt = [];\n operations = [];\n whitelist_update = Some Public;\n },\n ctxt )\n else tzfail Sc_rollup_errors.Sc_rollup_is_public\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* decoded_outbox_msg, ctxt =\n Sc_rollup_management_protocol.outbox_message_of_outbox_message_repr\n ctxt\n message\n in\n let* receipt, ctxt =\n match decoded_outbox_msg with\n | Sc_rollup_management_protocol.Atomic_transaction_batch {transactions} ->\n execute_outbox_message_transaction ctxt ~transactions ~rollup\n | Sc_rollup_management_protocol.Whitelist_update whitelist ->\n let is_enabled = Constants.sc_rollup_private_enable ctxt in\n if is_enabled then\n execute_outbox_message_whitelist_update\n ctxt\n ~rollup\n ~whitelist\n ~outbox_level\n ~message_index\n else tzfail Sc_rollup_errors.Sc_rollup_whitelist_disabled\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: https://gitlab.com/tezos/tezos/-/issues/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 applied_msg_size_diff = Z.max Z.zero applied_msg_size_diff in\n return\n ( {\n receipt with\n paid_storage_size_diff =\n Z.add receipt.paid_storage_size_diff applied_msg_size_diff;\n },\n 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 level slot consensus_key attestation] checks\n whether the DAL attestation [attestation] emitted at given [level] by the\n attester with the given [consensus_key] and given [slot] is valid. If an\n [Error _] is returned, the [op] is not valid. The checks made are:\n * the attestation size does not exceed the maximum;\n * the delegate is in the DAL committee.\n\n These are checks done for the DAL part alone, checks on other fields of an\n attestation (like level, round) are done by the caller. *)\nval validate_attestation :\n t ->\n Raw_level.t ->\n Slot.t ->\n Consensus_key.pk ->\n Dal.Attestation.t ->\n unit tzresult Lwt.t\n\n(** [apply_attestation ctxt attestation] records in the context that the given\n [attestation] was issued and the corresponding attester has the given\n [power]. *)\nval apply_attestation : t -> Dal.Attestation.t -> power:int -> t tzresult\n\n(** [validate_publish_commitment ctxt slot] ensures that [slot_header] is\n valid and prevents 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_commitment :\n t -> Dal.Operations.Publish_commitment.t -> unit tzresult\n\n(** [apply_publish_commitment 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_commitment :\n t -> Dal.Operations.Publish_commitment.t -> (t * Dal.Slot.Header.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) 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 ~number_of_slots n =\n let open Result_syntax in\n match Dal.Slot_index.of_int_opt ~number_of_slots n with\n | None ->\n tzfail\n @@ Dal_errors.Dal_slot_index_above_hard_limit\n {given = n; limit = number_of_slots - 1}\n | Some slot_index -> return slot_index\n\n(* Use this function to select the pkh used in the DAL committee. As long as an\n epoch does not span across multiple cycles, we could use as well the pkh of\n the consensus key. *)\nlet pkh_of_consensus_key (consensus_key : Consensus_key.pk) =\n consensus_key.delegate\n\nlet validate_attestation ctxt level slot consensus_key attestation =\n let open Lwt_result_syntax in\n let*? () = assert_dal_feature_enabled ctxt in\n let number_of_slots = Dal.number_of_slots ctxt in\n let*? max_index = number_of_slots - 1 |> slot_of_int_e ~number_of_slots 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 number_of_shards = Dal.number_of_shards ctxt in\n fail_when\n Compare.Int.(Slot.to_int slot >= number_of_shards)\n (let attester = pkh_of_consensus_key consensus_key in\n Dal_data_availibility_attester_not_in_committee {attester; level; slot})\n\nlet apply_attestation ctxt attestation ~power =\n let open Result_syntax in\n let* () = assert_dal_feature_enabled ctxt in\n return\n (Dal.Attestation.record_number_of_attested_shards ctxt attestation power)\n\n(* This function should fail if we don't want the operation to be\n propagated over the L1 gossip network. Because this is a manager\n operation, there are already checks to ensure the source of\n operation has enough fees. Among the various checks, there are\n checks that cannot fail unless the source of the operation is\n malicious (or if there is a bug). In that case, it is better to\n ensure fees will be taken. *)\nlet validate_publish_commitment ctxt _operation =\n assert_dal_feature_enabled ctxt\n\nlet apply_publish_commitment ctxt operation =\n let open Result_syntax in\n let* ctxt = Gas.consume ctxt Dal_costs.cost_Dal_publish_commitment in\n let number_of_slots = Dal.number_of_slots ctxt in\n let* ctxt, cryptobox = Dal.make ctxt in\n let current_level = (Level.current ctxt).level in\n let* slot_header =\n Dal.Operations.Publish_commitment.slot_header\n ~cryptobox\n ~number_of_slots\n ~current_level\n operation\n in\n let* ctxt = Dal.Slot.register_slot_header ctxt slot_header in\n return (ctxt, slot_header)\n\nlet finalisation ctxt =\n let open Lwt_result_syntax in\n only_if_dal_feature_enabled\n ctxt\n ~default:(fun ctxt -> return (ctxt, Dal.Attestation.empty))\n (fun ctxt ->\n let*! ctxt = Dal.Slot.finalize_current_slot_headers ctxt in\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 let number_of_slots = (Constants.parametric ctxt).dal.number_of_slots in\n let+ ctxt, attestation =\n Dal.Slot.finalize_pending_slot_headers ctxt ~number_of_slots\n in\n (ctxt, attestation))\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 }\n {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 let open Lwt_result_syntax in\n let*? Ex_comparable_ty contents_type, ctxt =\n Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty)\n in\n let* contents, ctxt =\n Script_ir_translator.parse_comparable_data\n ctxt\n contents_type\n (Micheline.root contents)\n in\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.zk_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 ~sender_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_attestation_power of {\n attestation_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 attestation in\n the next block.\n\n @return map from delegates with such rights to their attesting slots, in\n increasing order.\n\n This function is only used by the 'validators' RPC. *)\nval attesting_rights :\n context ->\n Level.t ->\n (context * ordered_slots Signature.Public_key_hash.Map.t) tzresult Lwt.t\n\n(** Computes attesting rights for a given level.\n\n @return map from allocated first slots to their owner's public key, consensus\n attesting power, and DAL attesting power. *)\nval attesting_rights_by_first_slot :\n context ->\n Level.t ->\n (context * (Consensus_key.pk * int * int) Slot.Map.t) tzresult Lwt.t\n\n(** Computes the bonus baking reward depending on the attestation power. *)\nval bonus_baking_reward : context -> attestation_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_attestation_power of {\n attestation_power : int;\n consensus_threshold : int;\n }\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"baking.insufficient_attestation_power\"\n ~title:\"Insufficient attestation power\"\n ~description:\n \"The attestation power is insufficient to satisfy the consensus \\\n threshold.\"\n ~pp:(fun ppf (attestation_power, consensus_threshold) ->\n Format.fprintf\n ppf\n \"The attestation power (%d) is insufficient to satisfy the consensus \\\n threshold (%d).\"\n attestation_power\n consensus_threshold)\n Data_encoding.(\n obj2 (req \"attestation_power\" int31) (req \"consensus_threshold\" int31))\n (function\n | Insufficient_attestation_power {attestation_power; consensus_threshold}\n ->\n Some (attestation_power, consensus_threshold)\n | _ -> None)\n (fun (attestation_power, consensus_threshold) ->\n Insufficient_attestation_power {attestation_power; consensus_threshold})\n\nlet bonus_baking_reward ctxt ~attestation_power =\n let open Result_syntax in\n let consensus_threshold = Constants.consensus_threshold ctxt in\n let* baking_reward_bonus_per_slot =\n Delegate.Rewards.baking_reward_bonus_per_slot ctxt\n in\n let extra_attestation_power = attestation_power - consensus_threshold in\n let* () =\n error_when\n Compare.Int.(extra_attestation_power < 0)\n (Insufficient_attestation_power {attestation_power; consensus_threshold})\n in\n Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_attestation_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 attesting_rights (ctxt : t) level =\n let consensus_committee_size = Constants.consensus_committee_size ctxt in\n let open Lwt_result_syntax in\n let*? slots = Slot.Range.create ~min:0 ~count:consensus_committee_size in\n Slot.Range.rev_fold_es\n (fun (ctxt, map) slot ->\n let* ctxt, consensus_pk = Stake_distribution.slot_owner ctxt level slot in\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 attesting_rights_by_first_slot ctxt level =\n let open Lwt_result_syntax in\n let*? slots =\n Slot.Range.create ~min:0 ~count:(Constants.consensus_committee_size ctxt)\n in\n let number_of_shards = Dal.number_of_shards ctxt in\n let* ctxt, (_, slots_map) =\n Slot.Range.fold_es\n (fun (ctxt, (delegates_map, slots_map)) slot ->\n let+ ctxt, consensus_pk =\n Stake_distribution.slot_owner ctxt level slot\n in\n let initial_slot, delegates_map =\n match\n Signature.Public_key_hash.Map.find\n consensus_pk.delegate\n 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 in_dal_committee =\n if Compare.Int.(Slot.to_int slot < number_of_shards) then 1 else 0\n in\n let slots_map =\n Slot.Map.update\n initial_slot\n (function\n | None -> Some (consensus_pk, 1, in_dal_committee)\n | Some (consensus_pk, count, dal_count) ->\n Some (consensus_pk, count + 1, dal_count + in_dal_committee))\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 in\n 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 = Preattestation | Attestation\n\n (** Errors for preattestations and attestations. *)\n type error +=\n | Forbidden_delegate 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_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_preattestation_in_block\n | Unexpected_attestation_in_block\n | Preattestation_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 = Misbehaviour.kind\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 | Sc_rollup_arith_pvm_disabled\n | Sc_rollup_riscv_pvm_disabled\n | Zk_rollup_feature_disabled\nend\n\ntype error += Failing_noop_error\n\nmodule Block : sig\n type error +=\n | Not_enough_attestations of {required : int; provided : int}\n | Inconsistent_validation_passes_in_block of {\n expected : int;\n provided : int;\n }\n | Invalid_payload_hash of {\n expected : Block_payload_hash.t;\n provided : Block_payload_hash.t;\n }\n | Locked_round_after_block_round of {\n locked_round : Round.t;\n round : Round.t;\n }\n | Insufficient_locked_round_evidence of {\n voting_power : int;\n consensus_threshold : 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 += Forbidden_delegate of Signature.Public_key_hash.t\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"validate.temporarily_forbidden_delegate\"\n ~title:\"Temporarily forbidden delegate\"\n ~description:\"The delegate has committed too many misbehaviours.\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"Delegate %a has committed too many misbehaviours; it is temporarily \\\n not allowed to bake/preattest/attest.\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Forbidden_delegate delegate -> Some delegate | _ -> None)\n (fun delegate -> Forbidden_delegate delegate)\n\n (** This type is only used in consensus operation errors to make\n them more informative. *)\n type consensus_operation_kind = Preattestation | Attestation\n\n let consensus_operation_kind_encoding =\n Data_encoding.string_enum\n [(\"Preattestation\", Preattestation); (\"Attestation\", Attestation)]\n\n let consensus_operation_kind_pp fmt = function\n | Preattestation -> Format.fprintf fmt \"Preattestation\"\n | Attestation -> Format.fprintf fmt \"Attestation\"\n\n (** Errors for preattestation and attestation. *)\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_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_preattestation_in_block\n | Unexpected_attestation_in_block\n | Preattestation_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 (* 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_preattestation_in_block\"\n ~title:\"Unexpected preattestation in block\"\n ~description:\"Unexpected preattestation in block.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Unexpected preattestation in block.\")\n Data_encoding.empty\n (function Unexpected_preattestation_in_block -> Some () | _ -> None)\n (fun () -> Unexpected_preattestation_in_block) ;\n register_error_kind\n `Permanent\n ~id:\"validate.unexpected_attestation_in_block\"\n ~title:\"Unexpected attestation in block\"\n ~description:\"Unexpected attestation in block.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Unexpected attestation in block.\")\n Data_encoding.empty\n (function Unexpected_attestation_in_block -> Some () | _ -> None)\n (fun () -> Unexpected_attestation_in_block) ;\n register_error_kind\n `Permanent\n ~id:\"validate.preattestation_round_too_high\"\n ~title:\"Preattestation round too high\"\n ~description:\"Preattestation round too high.\"\n ~pp:(fun ppf (block_round, provided) ->\n Format.fprintf\n ppf\n \"Preattestation 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 | Preattestation_round_too_high {block_round; provided} ->\n Some (block_round, provided)\n | _ -> None)\n (fun (block_round, provided) ->\n Preattestation_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 preattestation or attestation.\"\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 = Misbehaviour.kind\n\n let pp_denunciation_kind fmt : denunciation_kind -> unit = function\n | Double_preattesting -> Format.fprintf fmt \"preattestation\"\n | Double_attesting -> Format.fprintf fmt \"attestation\"\n | Double_baking -> 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\" Misbehaviour.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\" Misbehaviour.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 Signature.Public_key_hash.pp\n delegate\n Level.pp\n level\n pp_denunciation_kind\n kind)\n Data_encoding.(\n obj3\n (req \"denunciation_kind\" Misbehaviour.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\" Misbehaviour.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\" Misbehaviour.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\" Misbehaviour.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 | Sc_rollup_arith_pvm_disabled\n | Sc_rollup_riscv_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\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 scoru_riscv_pvm_disabled_description =\n \"RISCV PVM is disabled in this network.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operation.riscv_pvm_disabled\"\n ~title:\"The RISCV PVM is disabled\"\n ~description:scoru_riscv_pvm_disabled_description\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"%s\" scoru_riscv_pvm_disabled_description)\n Data_encoding.unit\n (function Sc_rollup_riscv_pvm_disabled -> Some () | _ -> None)\n (fun () -> Sc_rollup_riscv_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 (* All block errors are permanent. *)\n type error +=\n | Not_enough_attestations of {required : int; provided : int}\n | Inconsistent_validation_passes_in_block of {\n expected : int;\n provided : int;\n }\n | Invalid_payload_hash of {\n expected : Block_payload_hash.t;\n provided : Block_payload_hash.t;\n }\n | Locked_round_after_block_round of {\n locked_round : Round.t;\n round : Round.t;\n }\n | Insufficient_locked_round_evidence of {\n voting_power : int;\n consensus_threshold : int;\n }\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"validate.block.not_enough_attestations\"\n ~title:\"Not enough attestations\"\n ~description:\n \"The block being validated does not include the required minimum \\\n number of attestations.\"\n ~pp:(fun ppf (required, provided) ->\n Format.fprintf\n ppf\n \"Wrong number of attestations (%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_attestations {required; provided} ->\n Some (required, provided)\n | _ -> None)\n (fun (required, provided) -> Not_enough_attestations {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}) ;\n register_error_kind\n `Permanent\n ~id:\"validate.block.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:\"validate.block.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.pp\n locked_round\n Round.pp\n round)\n Data_encoding.(\n obj2 (req \"locked_round\" Round.encoding) (req \"round\" Round.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:\"validate.block.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})\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 let open Lwt_result_syntax in\n let* proposals = Vote.get_proposals ctxt in\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 let* max_vote = Vote.get_total_voting_power_free ctxt in\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) ~total_voting_power\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 total_voting_power)))\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 let open Lwt_result_syntax in\n let* ballots = Vote.get_ballots ctxt in\n let* total_voting_power = Vote.get_total_voting_power_free ctxt in\n let* participation_ema = Vote.get_participation_ema ctxt in\n let* expected_quorum = Vote.get_current_quorum ctxt in\n let*! ctxt = Vote.clear_ballots ctxt in\n let approval, new_participation_ema =\n approval_and_participation_ema\n ballots\n ~total_voting_power\n ~participation_ema\n ~expected_quorum\n in\n let+ ctxt = Vote.set_participation_ema ctxt new_participation_ema in\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 let open Lwt_result_syntax in\n let* kind = Voting_period.get_current_kind ctxt in\n let* ctxt =\n match kind with\n | Proposal -> (\n let* proposal = select_winning_proposal ctxt in\n let*! ctxt = Vote.clear_proposals ctxt in\n match proposal with\n | None -> Voting_period.reset ctxt\n | Some proposal ->\n let* ctxt = Vote.init_current_proposal ctxt proposal in\n Voting_period.succ ctxt)\n | Exploration ->\n let* ctxt, approved = get_approval_and_update_participation_ema ctxt in\n if approved then Voting_period.succ ctxt\n else\n let*! ctxt = Vote.clear_current_proposal ctxt in\n Voting_period.reset ctxt\n | Cooldown -> Voting_period.succ ctxt\n | Promotion ->\n let* ctxt, approved = get_approval_and_update_participation_ema ctxt in\n if approved then Voting_period.succ ctxt\n else\n let*! ctxt = Vote.clear_current_proposal ctxt in\n Voting_period.reset ctxt\n | Adoption ->\n let* proposal = Vote.get_current_proposal ctxt in\n let*! ctxt = activate ctxt proposal in\n let*! ctxt = Vote.clear_current_proposal ctxt in\n Voting_period.reset ctxt\n in\n Vote.update_listings ctxt\n\nlet may_start_new_voting_period ctxt =\n let open Lwt_result_syntax in\n let* is_last = Voting_period.is_last_block ctxt in\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 attestation 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 attestation 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)attesting power; the\n baker 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 validation_state\n\n(** Similar to [begin_partial_construction] but do not require\n predecessor information that is essential to the validation of\n preattestation and attestation 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 (Attestation 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 {!type-info} as input rather than a full\n {!type-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\ntype consensus_info = {\n predecessor_level : Raw_level.t;\n predecessor_round : Round.t;\n preattestation_slot_map : (Consensus_key.pk * int * int) Slot.Map.t option;\n attestation_slot_map : (Consensus_key.pk * int * int) Slot.Map.t option;\n}\n\nlet init_consensus_info ctxt (predecessor_level, predecessor_round) =\n {\n predecessor_level;\n predecessor_round;\n preattestation_slot_map = Consensus.allowed_preattestations ctxt;\n attestation_slot_map = Consensus.allowed_attestations ctxt;\n }\n\n(** Map used to detect consensus operation conflicts. Each delegate may\n (pre)attest at most once for each level and round, so two attestations\n (resp. two DAL attestations or two preattestations) conflict when they have\n the same slot, level, and round.\n\n Note that when validating the mempool, several (DAL/pre)attestations by the\n same delegate at the same level and round would not conflict if they have\n different Tenderbake slots.\n\n Note that when validating a block, all attestations (resp. all\n preattestations) must have the same level and round anyway, so only\n the slot is relevant. Taking the level and round into account is\n useful in mempool mode, because we want to be able to accept and\n propagate consensus operations for multiple close\n past/future/cousin blocks. *)\nmodule Consensus_conflict_map = Map.Make (struct\n type t = Slot.t * Raw_level.t * Round.t\n\n let compare (slot1, level1, round1) (slot2, level2, round2) =\n Compare.or_else (Raw_level.compare level1 level2) @@ fun () ->\n Compare.or_else (Slot.compare slot1 slot2) @@ fun () ->\n Round.compare round1 round2\nend)\n\ntype consensus_state = {\n preattestations_seen : Operation_hash.t Consensus_conflict_map.t;\n attestations_seen : Operation_hash.t Consensus_conflict_map.t;\n}\n\nlet consensus_conflict_map_encoding =\n let open Data_encoding in\n conv\n (fun map -> Consensus_conflict_map.bindings map)\n (fun l ->\n Consensus_conflict_map.(\n List.fold_left (fun m (k, v) -> add k v m) empty l))\n (list\n (tup2\n (tup3 Slot.encoding Raw_level.encoding Round.encoding)\n Operation_hash.encoding))\n\nlet consensus_state_encoding =\n let open Data_encoding in\n def \"consensus_state\"\n @@ conv\n (fun {preattestations_seen; attestations_seen} ->\n (preattestations_seen, attestations_seen))\n (fun (preattestations_seen, attestations_seen) ->\n {preattestations_seen; attestations_seen})\n (obj2\n (req \"preattestations_seen\" consensus_conflict_map_encoding)\n (req \"attestations_seen\" consensus_conflict_map_encoding))\n\nlet empty_consensus_state =\n {\n preattestations_seen = Consensus_conflict_map.empty;\n attestations_seen = Consensus_conflict_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_operation_evidence_map = struct\n include Map.Make (struct\n type t = Raw_level.t * Round.t * Slot.t * Misbehaviour.kind\n\n let compare (l, r, s, k) (l', r', s', k') =\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 () ->\n Misbehaviour.compare_kind k k'\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 (tup4\n Raw_level.encoding\n Round.encoding\n Slot.encoding\n Misbehaviour.kind_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_attesting_evidences_seen :\n Operation_hash.t Double_operation_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_attesting_evidences_seen;\n seed_nonce_levels_seen;\n vdf_solution_seen;\n } ->\n ( activation_pkhs_seen,\n double_baking_evidences_seen,\n double_attesting_evidences_seen,\n seed_nonce_levels_seen,\n vdf_solution_seen ))\n (fun ( activation_pkhs_seen,\n double_baking_evidences_seen,\n double_attesting_evidences_seen,\n seed_nonce_levels_seen,\n vdf_solution_seen ) ->\n {\n activation_pkhs_seen;\n double_baking_evidences_seen;\n double_attesting_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_attesting_evidences_seen\"\n (Double_operation_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_attesting_evidences_seen = Double_operation_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(** Information needed to validate consensus operations and/or to\n finalize the block in both modes that handle a preexisting block:\n [Application] and [Partial_validation]. *)\ntype block_info = {\n round : Round.t;\n locked_round : Round.t option;\n predecessor_hash : Block_hash.t;\n header_contents : Block_header.contents;\n}\n\n(** Information needed to validate consensus operations and/or to\n finalize the block in [Construction] mode. *)\ntype construction_info = {\n round : Round.t;\n predecessor_hash : Block_hash.t;\n header_contents : Block_header.contents;\n}\n\n(** Circumstances in which operations are validated, and corresponding\n specific information.\n\n If you add a new mode, please make sure that it has a way to bound\n the size of the maps in the {!operation_conflict_state}. *)\ntype mode =\n | Application of block_info\n (** [Application] is used for the validation of a preexisting block,\n often in preparation for its future application. *)\n | Partial_validation of block_info\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 | Construction of construction_info\n (** Used for the construction of a new block. *)\n | Mempool\n (** Used by the mempool ({!module:Mempool_validation}) and by the\n [Partial_construction] mode in {!module:Main}, which may itself be\n used by RPCs or by another mempool implementation. *)\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 option;\n (** Needed to validate consensus operations. This can be [None] during\n some RPC calls when some predecessor information is unavailable,\n in which case the validation of all consensus operations will\n systematically fail. *)\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 attestation_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 result_error = Result_syntax.tzfail\n\nlet init_info ctxt mode chain_id ~predecessor_level_and_round =\n let consensus_info =\n Option.map (init_consensus_info ctxt) predecessor_level_and_round\n in\n {\n ctxt;\n mode;\n chain_id;\n current_level = Level.current ctxt;\n consensus_info;\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 empty_operation_conflict_state =\n {\n consensus_state = empty_consensus_state;\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 attestation_power = 0;\n }\n\nlet get_initial_ctxt {info; _} = info.ctxt\n\n(** Validation of consensus operations (validation pass [0]):\n preattestations and attestations. *)\nmodule Consensus = struct\n open Validate_errors.Consensus\n\n let check_delegate_is_not_forbidden ctxt delegate_pkh =\n fail_when\n (Delegate.is_forbidden_delegate ctxt delegate_pkh)\n (Forbidden_delegate delegate_pkh)\n\n let get_delegate_details slot_map kind slot =\n let open Result_syntax in\n match slot_map with\n | None -> tzfail (Consensus.Slot_map_not_found {loc = __LOC__})\n | Some slot_map -> (\n match Slot.Map.find slot slot_map with\n | None -> tzfail (Wrong_slot_used_for_consensus_operation {kind})\n | Some x -> return x)\n\n (** When validating a block (ie. in [Application],\n [Partial_validation], and [Construction] modes), any\n preattestations must point to a round that is strictly before the\n block's round. *)\n let check_round_before_block ~block_round provided =\n error_unless\n Round.(provided < block_round)\n (Preattestation_round_too_high {block_round; provided})\n\n let check_level kind expected provided =\n (* We use [if] instead of [error_unless] to avoid computing the\n error when it is not needed. *)\n if Raw_level.equal expected provided then Result.return_unit\n else if Raw_level.(expected > provided) then\n result_error\n (Consensus_operation_for_old_level {kind; expected; provided})\n else\n result_error\n (Consensus_operation_for_future_level {kind; expected; provided})\n\n let check_round kind expected provided =\n (* We use [if] instead of [error_unless] to avoid computing the\n error when it is not needed. *)\n if Round.equal expected provided then ok_unit\n else if Round.(expected > provided) then\n result_error\n (Consensus_operation_for_old_round {kind; expected; provided})\n else\n result_error\n (Consensus_operation_for_future_round {kind; expected; provided})\n\n let check_payload_hash kind expected provided =\n error_unless\n (Block_payload_hash.equal expected provided)\n (Wrong_payload_hash_for_consensus_operation {kind; expected; provided})\n\n (** Preattestation checks for both [Application] and\n [Partial_validation] modes.\n\n Return the slot owner's consensus key and voting power. *)\n let check_preexisting_block_preattestation vi consensus_info block_info\n {level; round; block_payload_hash = bph; slot} =\n let open Lwt_result_syntax in\n let*? locked_round =\n match block_info.locked_round with\n | Some locked_round -> Ok locked_round\n | None ->\n (* A preexisting block whose fitness has no locked round\n should contain no preattestations. *)\n error Unexpected_preattestation_in_block\n in\n let kind = Preattestation in\n let*? () = check_round_before_block ~block_round:block_info.round round in\n let*? () = check_level kind vi.current_level.level level in\n let*? () = check_round kind locked_round round in\n let expected_payload_hash = block_info.header_contents.payload_hash in\n let*? () = check_payload_hash kind expected_payload_hash bph in\n let*? consensus_key, voting_power, _dal_power =\n get_delegate_details consensus_info.preattestation_slot_map kind slot\n in\n return (consensus_key, voting_power)\n\n (** Preattestation checks for Construction mode.\n\n Return the slot owner's consensus key and voting power. *)\n let check_constructed_block_preattestation vi consensus_info cons_info\n {level; round; block_payload_hash = bph; slot} =\n let open Lwt_result_syntax in\n let expected_payload_hash = cons_info.header_contents.payload_hash in\n let*? () =\n (* When the proposal is fresh, a fake [payload_hash] of [zero]\n has been provided. In this case, the block should not contain\n any preattestations. *)\n error_when\n Block_payload_hash.(expected_payload_hash = zero)\n Unexpected_preattestation_in_block\n in\n let kind = Preattestation in\n let*? () = check_round_before_block ~block_round:cons_info.round round in\n let*? () = check_level kind vi.current_level.level level in\n (* We cannot check the exact round here in construction mode, because\n there is no preexisting fitness to provide the locked_round. We do\n however check that all preattestations have the same round in\n [check_construction_preattestation_round_consistency] further below. *)\n let*? () = check_payload_hash kind expected_payload_hash bph in\n let*? consensus_key, voting_power, _dal_power =\n get_delegate_details consensus_info.preattestation_slot_map kind slot\n in\n return (consensus_key, voting_power)\n\n (** Preattestation/attestation checks for Mempool mode.\n\n We want this mode to be very permissive, to allow the mempool to\n accept and propagate consensus operations even if they point to a\n block which is not known to the mempool (e.g. because the block\n has just been validated and the mempool has not had time to\n switch its head to it yet, or because the block belongs to a\n cousin branch). Therefore, we do not check the round nor the\n payload, which may correspond to blocks that we do not know of\n yet. As to the level, we only require it to be the\n [predecessor_level] (aka the level of the mempool's head) plus or\n minus one, that is:\n [predecessor_level - 1 <= op_level <= predecessor_level + 1]\n (note that [predecessor_level + 1] is also known as [current_level]).\n\n Note that we also don't check whether the slot is normalized\n (that is, whether it is the delegate's smallest slot). Indeed,\n we don't want to compute the right tables by first slot for all\n three allowed levels. Checking the slot normalization is\n therefore the responsability of the baker when it selects\n the consensus operations to include in a new block. Moreover,\n multiple attestations pointing to the same block with different\n slots can be punished by a double-(pre)attestation operation.\n\n Return the slot owner's consensus key and a fake voting power (the\n latter won't be used anyway in Mempool mode). *)\n let check_mempool_consensus vi consensus_info kind {level; slot; _} =\n let open Lwt_result_syntax in\n let*? () =\n if Raw_level.(succ level < consensus_info.predecessor_level) then\n let expected = consensus_info.predecessor_level and provided = level in\n result_error\n (Consensus_operation_for_old_level {kind; expected; provided})\n else if Raw_level.(level > vi.current_level.level) then\n let expected = consensus_info.predecessor_level and provided = level in\n result_error\n (Consensus_operation_for_future_level {kind; expected; provided})\n else ok_unit\n in\n let* (_ctxt : t), consensus_key =\n Stake_distribution.slot_owner vi.ctxt (Level.from_raw vi.ctxt level) slot\n in\n return (consensus_key, 0 (* Fake voting power *))\n (* We do not check that the frozen deposits are positive because this\n only needs to be true in the context of a block that actually\n contains the operation, which may not be the same as the current\n mempool's context. *)\n\n let check_preattestation vi ~check_signature\n (operation : Kind.preattestation operation) =\n let open Lwt_result_syntax in\n let*? consensus_info =\n Option.value_e\n ~error:(trace_of_error Consensus_operation_not_allowed)\n vi.consensus_info\n in\n let (Single (Preattestation consensus_content)) =\n operation.protocol_data.contents\n in\n let* consensus_key, voting_power =\n match vi.mode with\n | Application block_info | Partial_validation block_info ->\n check_preexisting_block_preattestation\n vi\n consensus_info\n block_info\n consensus_content\n | Construction construction_info ->\n check_constructed_block_preattestation\n vi\n consensus_info\n construction_info\n consensus_content\n | Mempool ->\n check_mempool_consensus\n vi\n consensus_info\n Preattestation\n consensus_content\n in\n let* () = check_delegate_is_not_forbidden vi.ctxt consensus_key.delegate 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_preattestation_conflict vs oph (op : Kind.preattestation operation)\n =\n let (Single (Preattestation {slot; level; round; _})) =\n op.protocol_data.contents\n in\n match\n Consensus_conflict_map.find_opt\n (slot, level, round)\n vs.consensus_state.preattestations_seen\n with\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n | None -> ok_unit\n\n let wrap_preattestation_conflict = function\n | Ok () -> ok_unit\n | Error conflict ->\n result_error\n Validate_errors.Consensus.(\n Conflicting_consensus_operation {kind = Preattestation; conflict})\n\n let add_preattestation vs oph (op : Kind.preattestation operation) =\n let (Single (Preattestation {slot; level; round; _})) =\n op.protocol_data.contents\n in\n let preattestations_seen =\n Consensus_conflict_map.add\n (slot, level, round)\n oph\n vs.consensus_state.preattestations_seen\n in\n {vs with consensus_state = {vs.consensus_state with preattestations_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 -> (* The block_state is not relevant in this mode. *) 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\n {!check_preattestation_content_preexisting_block} in\n application and partial validation modes, and by\n {!check_construction_preattestation_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_preattestation vs (operation : Kind.preattestation operation) =\n (* As we are in mempool mode, we do not update\n [locked_round_evidence]. *)\n let (Single (Preattestation {slot; level; round; _})) =\n operation.protocol_data.contents\n in\n let preattestations_seen =\n Consensus_conflict_map.remove\n (slot, level, round)\n vs.consensus_state.preattestations_seen\n in\n {vs with consensus_state = {vs.consensus_state with preattestations_seen}}\n\n (** Attestation checks for all modes that involve a block:\n Application, Partial_validation, and Construction.\n Checks regarding the DAL content are done separately.\n\n Return the slot owner's consensus key and voting power. *)\n let check_block_attestation vi consensus_info\n {level; round; block_payload_hash = bph; slot} =\n let open Lwt_result_syntax in\n let*? expected_payload_hash =\n match Consensus.attestation_branch vi.ctxt with\n | Some ((_branch : Block_hash.t), payload_hash) -> Ok payload_hash\n | None ->\n (* [Consensus.attestation_branch] only returns [None] when the\n predecessor is the block that activates the first protocol\n of the Tenderbake family; this block should not be\n attested. This can only happen in tests and test\n networks. *)\n result_error Unexpected_attestation_in_block\n in\n let kind = Attestation in\n let*? () = check_level kind consensus_info.predecessor_level level in\n let*? () = check_round kind consensus_info.predecessor_round round in\n let*? () = check_payload_hash kind expected_payload_hash bph in\n let*? consensus_key, voting_power, _dal_power =\n get_delegate_details consensus_info.attestation_slot_map kind slot\n in\n return (consensus_key, voting_power)\n\n let check_attestation vi ~check_signature\n (operation : Kind.attestation operation) =\n let open Lwt_result_syntax in\n let*? consensus_info =\n Option.value_e\n ~error:(trace_of_error Consensus_operation_not_allowed)\n vi.consensus_info\n in\n let (Single (Attestation {consensus_content; dal_content})) =\n operation.protocol_data.contents\n in\n let* consensus_key, voting_power =\n match vi.mode with\n | Application _ | Partial_validation _ | Construction _ ->\n check_block_attestation vi consensus_info consensus_content\n | Mempool ->\n check_mempool_consensus\n vi\n consensus_info\n Attestation\n consensus_content\n in\n let* () = check_delegate_is_not_forbidden vi.ctxt consensus_key.delegate in\n let* () =\n Option.fold\n ~none:return_unit\n ~some:(fun dal ->\n Dal_apply.validate_attestation\n vi.ctxt\n consensus_content.level\n consensus_content.slot\n consensus_key\n dal.attestation)\n dal_content\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_attestation_conflict vs oph (operation : Kind.attestation operation)\n =\n let (Single\n (Attestation\n {consensus_content = {slot; level; round; _}; dal_content = _})) =\n operation.protocol_data.contents\n in\n match\n Consensus_conflict_map.find_opt\n (slot, level, round)\n vs.consensus_state.attestations_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_attestation_conflict = function\n | Ok () -> ok_unit\n | Error conflict ->\n result_error\n Validate_errors.Consensus.(\n Conflicting_consensus_operation {kind = Attestation; conflict})\n\n let add_attestation vs oph (op : Kind.attestation operation) =\n let (Single\n (Attestation\n {consensus_content = {slot; level; round; _}; dal_content = _})) =\n op.protocol_data.contents\n in\n let attestations_seen =\n Consensus_conflict_map.add\n (slot, level, round)\n oph\n vs.consensus_state.attestations_seen\n in\n {vs with consensus_state = {vs.consensus_state with attestations_seen}}\n\n let may_update_attestation_power vi block_state voting_power =\n match vi.mode with\n | Mempool -> (* The block_state is not relevant. *) block_state\n | Application _ | Partial_validation _ | Construction _ ->\n {\n block_state with\n attestation_power = block_state.attestation_power + voting_power;\n }\n\n (* Hypothesis: this function will only be called in mempool mode *)\n let remove_attestation vs (operation : Kind.attestation operation) =\n (* We do not remove the attestation power because it is not\n relevant for the mempool mode. *)\n let (Single\n (Attestation\n {consensus_content = {slot; level; round; _}; dal_content = _})) =\n operation.protocol_data.contents\n in\n let attestations_seen =\n Consensus_conflict_map.remove\n (slot, level, round)\n vs.consensus_state.attestations_seen\n in\n {vs with consensus_state = {vs.consensus_state with attestations_seen}}\n\n (** In Construction mode, check that the preattestation has the same\n round as any previously validated preattestations.\n\n This check is not needed in other modes because\n {!check_preattestation} already checks that all preattestations\n have the same expected round (the locked_round in Application and\n Partial_validation modes when there is one (otherwise all\n preattestations are rejected so the point is moot), or the\n predecessor_round in Mempool mode). *)\n let check_construction_preattestation_round_consistency vi block_state\n (consensus_content : consensus_content) =\n let open Result_syntax in\n match vi.mode with\n | Construction _ -> (\n match block_state.locked_round_evidence with\n | None ->\n (* This is the first validated preattestation:\n there is nothing to check. *)\n return_unit\n | Some (expected, _power) ->\n (* Other preattestations have already been validated: we check\n that the current operation has the same round as them. *)\n check_round Preattestation expected consensus_content.round)\n | Application _ | Partial_validation _ | Mempool -> return_unit\n\n let validate_preattestation ~check_signature info operation_state block_state\n oph (operation : Kind.preattestation operation) =\n let open Lwt_result_syntax in\n let (Single (Preattestation consensus_content)) =\n operation.protocol_data.contents\n in\n let* voting_power = check_preattestation info ~check_signature operation in\n let*? () =\n check_construction_preattestation_round_consistency\n info\n block_state\n consensus_content\n in\n let*? () =\n check_preattestation_conflict operation_state oph operation\n |> wrap_preattestation_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_preattestation operation_state oph operation in\n return {info; operation_state; block_state}\n\n let validate_attestation ~check_signature info operation_state block_state oph\n operation =\n let open Lwt_result_syntax in\n let* power = check_attestation info ~check_signature operation in\n let*? () =\n check_attestation_conflict operation_state oph operation\n |> wrap_attestation_conflict\n in\n let block_state = may_update_attestation_power info block_state power in\n let operation_state = add_attestation operation_state oph operation 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 [] -> tzfail 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 result_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 | _ :: _ :: _ -> result_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 result_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 result_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 -> result_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 open Lwt_result_syntax in\n let (Single (Activate_account {id = edpkh; activation_code})) =\n operation.protocol_data.contents\n 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 result_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 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_attesting_evidence (type kind) vi\n (op1 : kind Kind.consensus Operation.t)\n (op2 : kind Kind.consensus Operation.t) =\n let open Lwt_result_syntax in\n let e1, e2, kind =\n match (op1.protocol_data.contents, op2.protocol_data.contents) with\n | Single (Preattestation e1), Single (Preattestation e2) ->\n (e1, e2, Misbehaviour.Double_preattesting)\n | ( Single (Attestation {consensus_content = e1; dal_content = _}),\n Single (Attestation {consensus_content = e2; dal_content = _}) ) ->\n (e1, e2, Double_attesting)\n in\n let op1_hash = Operation.hash op1 in\n let op2_hash = Operation.hash op2 in\n let same_levels = Raw_level.(e1.level = e2.level) in\n let same_rounds = Round.(e1.round = e2.round) in\n let same_payload =\n Block_payload_hash.(e1.block_payload_hash = e2.block_payload_hash)\n in\n let same_branches = Block_hash.(op1.shell.branch = op2.shell.branch) in\n let same_slots = Slot.(e1.slot = e2.slot) in\n let ordered_hashes = Operation_hash.(op1_hash < op2_hash) in\n let is_denunciation_consistent =\n same_levels && same_rounds\n (* For the double (pre)attestations to be punishable, they\n must point to the same block (same level and round), but\n also have at least a difference that is the delegate's\n fault: different payloads, different branches, or\n different slots. Note that different payloads would\n endanger the consensus process, while different branches\n or slots could be used to spam mempools with a lot of\n valid operations (since the minimality of the slot in not\n checked in mempool mode, only in block-related modes). On\n the other hand, if the operations have identical levels,\n rounds, payloads, branches, and slots, then only their\n signatures are different, which is not considered the\n delegate's fault and therefore is not punished. *)\n && ((not same_payload) || (not same_branches) || not same_slots)\n && (* we require an order on hashes to avoid the existence of\n equivalent evidences *)\n ordered_hashes\n in\n let*? () =\n error_unless is_denunciation_consistent (Invalid_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 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 {kind; delegate1; delegate2})\n in\n let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in\n let* already_slashed =\n Delegate.already_denounced ctxt delegate level e1.round kind\n in\n let*? () =\n error_unless\n (not already_slashed)\n (Already_denounced {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_preattestation_evidence vi\n (operation : Kind.double_preattestation_evidence operation) =\n let (Single (Double_preattestation_evidence {op1; op2})) =\n operation.protocol_data.contents\n in\n check_double_attesting_evidence vi op1 op2\n\n let check_double_attestation_evidence vi\n (operation : Kind.double_attestation_evidence operation) =\n let (Single (Double_attestation_evidence {op1; op2})) =\n operation.protocol_data.contents\n in\n check_double_attesting_evidence vi op1 op2\n\n let double_operation_conflict_key (type kind)\n (op1 : kind Kind.consensus Operation.t) =\n let {slot; level; round; block_payload_hash = _}, kind =\n match op1.protocol_data.contents with\n | Single (Preattestation cc) -> (cc, Misbehaviour.Double_preattesting)\n | Single (Attestation {consensus_content; dal_content = _}) ->\n (consensus_content, Double_attesting)\n in\n (level, round, slot, kind)\n\n let check_double_attesting_evidence_conflict (type kind) vs oph\n (op1 : kind Kind.consensus Operation.t) =\n match\n Double_operation_evidence_map.find\n (double_operation_conflict_key op1)\n vs.anonymous_state.double_attesting_evidences_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let check_double_preattestation_evidence_conflict vs oph\n (operation : Kind.double_preattestation_evidence operation) =\n let (Single (Double_preattestation_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n check_double_attesting_evidence_conflict vs oph op1\n\n let check_double_attestation_evidence_conflict vs oph\n (operation : Kind.double_attestation_evidence operation) =\n let (Single (Double_attestation_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n check_double_attesting_evidence_conflict vs oph op1\n\n let wrap_denunciation_conflict kind = function\n | Ok () -> ok_unit\n | Error conflict -> result_error (Conflicting_denunciation {kind; conflict})\n\n let add_double_attesting_evidence (type kind) vs oph\n (op1 : kind Kind.consensus Operation.t) =\n let double_attesting_evidences_seen =\n Double_operation_evidence_map.add\n (double_operation_conflict_key op1)\n oph\n vs.anonymous_state.double_attesting_evidences_seen\n in\n {\n vs with\n anonymous_state =\n {vs.anonymous_state with double_attesting_evidences_seen};\n }\n\n let add_double_attestation_evidence vs oph\n (operation : Kind.double_attestation_evidence operation) =\n let (Single (Double_attestation_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n add_double_attesting_evidence vs oph op1\n\n let add_double_preattestation_evidence vs oph\n (operation : Kind.double_preattestation_evidence operation) =\n let (Single (Double_preattestation_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n add_double_attesting_evidence vs oph op1\n\n let remove_double_attesting_evidence (type kind) vs\n (op : kind Kind.consensus Operation.t) =\n let double_attesting_evidences_seen =\n Double_operation_evidence_map.remove\n (double_operation_conflict_key op)\n vs.anonymous_state.double_attesting_evidences_seen\n in\n let anonymous_state =\n {vs.anonymous_state with double_attesting_evidences_seen}\n in\n {vs with anonymous_state}\n\n let remove_double_preattestation_evidence vs\n (operation : Kind.double_preattestation_evidence operation) =\n let (Single (Double_preattestation_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n remove_double_attesting_evidence vs op1\n\n let remove_double_attestation_evidence vs\n (operation : Kind.double_attestation_evidence operation) =\n let (Single (Double_attestation_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n remove_double_attesting_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 Double_baking 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 = Double_baking; delegate1; delegate2})\n in\n let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in\n let* already_slashed =\n Delegate.already_denounced ctxt delegate level round1 Double_baking\n in\n let*? () =\n error_unless\n (not already_slashed)\n (Already_denounced {kind = Double_baking; 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 ->\n result_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 -> result_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 -> result_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 let check_source_and_counter ~expected_source ~source ~previous_counter\n ~counter =\n let open Result_syntax in\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\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 let open Result_syntax in\n fun expected_source previous_counter -> function\n | Single (Manager_operation {operation = Reveal _key; _}) ->\n tzfail Incorrect_reveal_position\n | Cons (Manager_operation {operation = Reveal _key; _}, _res) ->\n tzfail 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* () =\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\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 let open Result_syntax in\n fun contents_list ->\n match contents_list with\n | Single (Manager_operation {source; operation = Reveal key; counter; _})\n ->\n return (source, Some key, counter)\n | Single (Manager_operation {source; counter; _}) ->\n return (source, None, counter)\n | Cons\n (Manager_operation {source; operation = Reveal key; counter; _}, rest)\n ->\n let* () = check_batch_tail_sanity source counter rest in\n return (source, Some key, counter)\n | Cons (Manager_operation {source; counter; _}, rest) ->\n let* () = check_batch_tail_sanity source counter rest in\n return (source, None, counter)\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 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_pvm_kind_enabled vi kind =\n let open Result_syntax in\n let* () =\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 in\n error_when\n ((not (Constants.sc_rollup_riscv_pvm_enable vi.ctxt))\n && Sc_rollup.Kind.(equal kind Riscv))\n Sc_rollup_riscv_pvm_disabled\n\n let assert_not_zero_messages messages =\n match messages with\n | [] -> result_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 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_kind_specific_content (type kind)\n (contents : kind Kind.manager contents) remaining_gas vi =\n let open Result_syntax in\n let (Manager_operation\n {\n source;\n fee = _;\n counter = _;\n operation;\n gas_limit = _;\n storage_limit = _;\n }) =\n contents\n 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 | 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 | Sc_rollup_originate {kind; _} -> assert_pvm_kind_enabled vi kind\n | Sc_rollup_add_messages {messages; _} -> assert_not_zero_messages messages\n | Sc_rollup_cement _ | Sc_rollup_publish _ | Sc_rollup_refute _\n | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _\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 return_unit\n | Dal_publish_commitment slot_header ->\n Dal_apply.validate_publish_commitment vi.ctxt slot_header\n | Zk_rollup_origination _ | Zk_rollup_publish _ | Zk_rollup_update _ ->\n assert_zk_rollup_feature_enabled vi\n\n let check_contents (type kind) vi batch_state\n (contents : kind Kind.manager contents) ~consume_gas_for_sig_check\n 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 (* Part of the gas cost of the operation which is independent of\n the contents of the operation. It is\n Michelson_v1_gas.Cost_of.manager_operation constant plus the\n cost of checking the signature if the operation is the first of\n the batch. *)\n let fixed_gas_cost =\n let manager_op_cost = Michelson_v1_gas.Cost_of.manager_operation in\n match consume_gas_for_sig_check with\n | None -> manager_op_cost\n | Some gas_for_sig_check -> Gas.(manager_op_cost +@ gas_for_sig_check)\n in\n let*? remaining_gas =\n record_trace\n Insufficient_gas_for_manager\n (Gas.consume_from (Gas.Arith.fp gas_limit) fixed_gas_cost)\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*? () = check_kind_specific_content contents remaining_gas vi in\n (* Gas should no longer be consumed below this point, because it\n would not take into account any gas consumed by\n {!check_kind_specific_content}. If you really need to consume gas here, then you\n must make {!check_kind_specific_content} 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]. The\n [consume_gas_for_sig_check] arg indicates whether or not gas for\n checking the signature of the batch should be consumed; it is\n [None] if the cost has already been consumed and [Some cost] if\n the cost to be consumed is [cost] and remains to be\n consumed. This cost is consumed in the first operation of the\n batch. *)\n let rec check_contents_list :\n type kind.\n info ->\n batch_state ->\n kind Kind.manager contents_list ->\n consume_gas_for_sig_check:Gas.cost option ->\n Gas.Arith.fp ->\n Gas.Arith.fp tzresult Lwt.t =\n fun vi batch_state contents_list ~consume_gas_for_sig_check remaining_gas ->\n let open Lwt_result_syntax in\n match contents_list with\n | Single contents ->\n let* batch_state =\n check_contents\n vi\n batch_state\n contents\n ~consume_gas_for_sig_check\n remaining_gas\n in\n return batch_state.total_gas_used\n | Cons (contents, tail) ->\n let* batch_state =\n check_contents\n vi\n batch_state\n contents\n ~consume_gas_for_sig_check\n remaining_gas\n in\n check_contents_list\n vi\n batch_state\n tail\n ~consume_gas_for_sig_check:None\n 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 signature_checking_gas_cost =\n Operation_costs.check_signature_cost\n (Michelson_v1_gas.Cost_of.Interpreter.algo_of_public_key source_pk)\n operation\n in\n let* gas_used =\n check_contents_list\n vi\n batch_state\n contents_list\n ~consume_gas_for_sig_check:(Some signature_checking_gas_cost)\n 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 -> result_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 ~predecessor_level_and_round =\n let info = init_info ctxt mode chain_id ~predecessor_level_and_round in\n let operation_state = empty_operation_conflict_state 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_delegate_is_not_forbidden ctxt block_producer.delegate\n in\n let* ctxt, _slot, _payload_producer =\n (* We just make sure that this call will not fail in apply.ml *)\n Stake_distribution.baking_rights_owner\n ctxt\n current_level\n ~round:block_header.protocol_data.contents.payload_round\n in\n let predecessor_hash = block_header.shell.predecessor in\n let block_info =\n {\n round;\n locked_round = Fitness.locked_round fitness;\n predecessor_hash;\n header_contents = block_header.protocol_data.contents;\n }\n in\n let mode =\n if is_partial then Partial_validation block_info else Application block_info\n in\n let validation_state =\n init_validation_state\n ctxt\n mode\n chain_id\n ~predecessor_level_and_round:\n (Some (predecessor_level.Level.level, predecessor_round))\n in\n return validation_state\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_delegate_is_not_forbidden ctxt block_producer.delegate\n in\n let* ctxt, _slot, _payload_producer =\n (* We just make sure that this call will not fail in apply.ml *)\n Stake_distribution.baking_rights_owner\n ctxt\n current_level\n ~round:header_contents.payload_round\n in\n let validation_state =\n init_validation_state\n ctxt\n (Construction {round; predecessor_hash; header_contents})\n chain_id\n ~predecessor_level_and_round:\n (Some (predecessor_level.Level.level, predecessor_round))\n in\n return validation_state\n\nlet begin_partial_construction ctxt chain_id ~predecessor_level\n ~predecessor_round =\n let validation_state =\n init_validation_state\n ctxt\n Mempool\n chain_id\n ~predecessor_level_and_round:\n (Some (predecessor_level.Level.level, predecessor_round))\n in\n validation_state\n\nlet begin_no_predecessor_info ctxt chain_id =\n init_validation_state ctxt Mempool chain_id ~predecessor_level_and_round:None\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 (Preattestation _) ->\n let* (_voting_power : int) =\n Consensus.check_preattestation info ~check_signature operation\n in\n return_unit\n | Single (Attestation _) ->\n let* (_voting_power : int) =\n Consensus.check_attestation info ~check_signature operation\n in\n return_unit\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_preattestation_evidence _) ->\n Anonymous.check_double_preattestation_evidence info operation\n | Single (Double_attestation_evidence _) ->\n Anonymous.check_double_attestation_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 (Preattestation _) ->\n Consensus.check_preattestation_conflict\n operation_conflict_state\n oph\n operation\n | Single (Attestation _) ->\n Consensus.check_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_preattestation_evidence _) ->\n Anonymous.check_double_preattestation_evidence_conflict\n operation_conflict_state\n oph\n operation\n | Single (Double_attestation_evidence _) ->\n Anonymous.check_double_attestation_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 (Preattestation _) ->\n Consensus.add_preattestation operation_conflict_state oph operation\n | Single (Attestation _) ->\n Consensus.add_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_preattestation_evidence _) ->\n Anonymous.add_double_preattestation_evidence\n operation_conflict_state\n oph\n operation\n | Single (Double_attestation_evidence _) ->\n Anonymous.add_double_attestation_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 (Preattestation _) ->\n Consensus.remove_preattestation operation_conflict_state operation\n | Single (Attestation _) ->\n Consensus.remove_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_preattestation_evidence _) ->\n Anonymous.remove_double_preattestation_evidence\n operation_conflict_state\n operation\n | Single (Double_attestation_evidence _) ->\n Anonymous.remove_double_attestation_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 operations in\n [Partial_validation] mode. *)\n return {info; operation_state; block_state}\n | (Application _ | Partial_validation _ | Construction _ | Mempool), _ -> (\n match operation.protocol_data.contents with\n | Single (Preattestation _) ->\n Consensus.validate_preattestation\n ~check_signature\n info\n operation_state\n block_state\n oph\n operation\n | Single (Attestation _) ->\n Consensus.validate_attestation\n ~check_signature\n info\n operation_state\n block_state\n oph\n operation\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_preattestation_evidence _) ->\n let open Anonymous in\n let* () = check_double_preattestation_evidence info operation in\n let*? () =\n check_double_preattestation_evidence_conflict\n operation_state\n oph\n operation\n |> wrap_denunciation_conflict Double_preattesting\n in\n let operation_state =\n add_double_preattestation_evidence operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Double_attestation_evidence _) ->\n let open Anonymous in\n let* () = check_double_attestation_evidence info operation in\n let*? () =\n check_double_attestation_evidence_conflict\n operation_state\n oph\n operation\n |> wrap_denunciation_conflict Double_attesting\n in\n let operation_state =\n add_double_attestation_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 Double_baking\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\n(** Block finalization *)\n\nopen Validate_errors.Block\n\nlet check_attestation_power vi bs =\n let open Lwt_result_syntax in\n let* are_attestations_required =\n (* The migration block (whose level is [first_level_of_protocol])\n is always considered final, and is not attested. Therefore, the\n block at the next level does not need to contain attestations.\n (Note that the migration block itself is validated by the\n previous protocol, so the returned value for it does not matter.) *)\n let* first_level_of_protocol = First_level_of_protocol.get vi.ctxt in\n let level_position_in_protocol =\n Raw_level.diff vi.current_level.level first_level_of_protocol\n in\n return Compare.Int32.(level_position_in_protocol > 1l)\n in\n if are_attestations_required then\n let required = Constants.consensus_threshold vi.ctxt in\n let provided = bs.attestation_power in\n fail_unless\n Compare.Int.(provided >= required)\n (Not_enough_attestations {required; provided})\n else return_unit\n\n(** Check that the locked round in the fitness and the locked round\n observed in the preattestations are the same.\n\n This check is not called in construction mode because there is\n no provided fitness (meaning that we do not know whether the block\n should contain any preattestations).\n\n When the observed locked round is [Some _], we actually already\n know that it is identical to the fitness locked round, otherwise\n {!Consensus.check_preexisting_block_preattestation} would have\n rejected the preattestations. But this check is needed to reject\n blocks where the fitness locked round has a value yet there are no\n preattestations (ie. the observed locked round is [None]). *)\nlet check_fitness_locked_round bs fitness_locked_round =\n let observed_locked_round = Option.map fst bs.locked_round_evidence in\n error_unless\n (Option.equal Round.equal observed_locked_round fitness_locked_round)\n Fitness.Wrong_fitness\n\n(** When there are preattestations, check that they point to a round\n before the block's round, and that their total power is high enough.\n\n Note that this function does not check whether the block actually\n contains preattestations when they are mandatory. This is checked by\n {!check_fitness_locked_round} instead. *)\nlet check_preattestation_round_and_power vi vs round =\n let open Result_syntax in\n match vs.locked_round_evidence with\n | None -> ok_unit\n | Some (preattestation_round, preattestation_count) ->\n let* () =\n (* Actually, this check should never fail, because we have\n already called {!Consensus.check_round_before_block} for\n all preattestations in a block. Nevertheless, it does not\n cost much to check again here. *)\n error_when\n Round.(preattestation_round >= round)\n (Locked_round_after_block_round\n {locked_round = preattestation_round; round})\n in\n let consensus_threshold = Constants.consensus_threshold vi.ctxt in\n error_when\n Compare.Int.(preattestation_count < consensus_threshold)\n (Insufficient_locked_round_evidence\n {voting_power = preattestation_count; consensus_threshold})\n\nlet check_payload_hash block_state ~predecessor_hash\n (block_header_contents : Block_header.contents) =\n let expected =\n Block_payload.hash\n ~predecessor_hash\n ~payload_round:block_header_contents.payload_round\n (List.rev block_state.recorded_operations_rev)\n in\n let provided = block_header_contents.payload_hash in\n error_unless\n (Block_payload_hash.equal expected provided)\n (Invalid_payload_hash {expected; provided})\n\nlet finalize_block {info; block_state; _} =\n let open Lwt_result_syntax in\n match info.mode with\n | Application {round; locked_round; predecessor_hash; header_contents} ->\n let* () = check_attestation_power info block_state in\n let*? () = check_fitness_locked_round block_state locked_round in\n let*? () = check_preattestation_round_and_power info block_state round in\n let*? () =\n check_payload_hash block_state ~predecessor_hash header_contents\n in\n return_unit\n | Partial_validation {round; locked_round; _} ->\n let* () = check_attestation_power info block_state in\n let*? () = check_fitness_locked_round block_state locked_round in\n let*? () = check_preattestation_round_and_power info block_state round in\n return_unit\n | Construction {round; predecessor_hash; header_contents} ->\n let* () = check_attestation_power info block_state in\n let*? () = check_preattestation_round_and_power info block_state round in\n let*? () =\n match block_state.locked_round_evidence with\n | Some _ ->\n check_payload_hash block_state ~predecessor_hash header_contents\n | None ->\n (* In construction mode, when there is no locked round\n evidence (ie. no preattestations), the baker cannot know\n the payload hash before selecting the operations.\n Therefore, we do not check the initially given payload\n hash. The baker will have to patch the resulting block\n header with the actual payload hash afterwards. *)\n ok_unit\n in\n return_unit\n | Mempool ->\n (* There is no block to finalize in 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 preattestations and\n attestations.\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 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 = 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\" 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 validation_info * t =\n let {info; operation_state; _} =\n begin_partial_construction\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_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 let open Result_syntax in\n if\n Block_hash.(\n existing_mempool.predecessor_hash <> new_mempool.predecessor_hash)\n then Error Incompatible_mempool\n else\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 | 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 {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 : Per_block_votes.Liquidity_baking_toggle_EMA.t;\n adaptive_issuance_vote_ema : Per_block_votes.Adaptive_issuance_launch_EMA.t;\n adaptive_issuance_launch_cycle : Cycle.t option;\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_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\nmodule Internal_for_benchmark : sig\n val take_fees : context -> 'a Kind.manager contents_list -> unit\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) 2022 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2023 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\n(** Tezos Protocol Implementation - Main Entry Points *)\n\nopen Alpha_context\n\ntype error +=\n | Faulty_validation_wrong_slot\n | Set_deposits_limit_on_unregistered_delegate of Signature.Public_key_hash.t\n | Set_deposits_limit_when_automated_staking_off\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 | Internal_operation_replay of\n Apply_internal_results.packed_internal_operation\n | Multiple_revelation\n | Invalid_transfer_to_sc_rollup\n | Invalid_sender of Destination.t\n | Invalid_self_transaction_destination\n | Staking_for_delegator_while_external_staking_disabled\n | Staking_to_delegate_that_refuses_external_staking\n | Stake_modification_with_no_delegate_set\n | Invalid_nonzero_transaction_amount of Tez.t\n | Invalid_staking_parameters_sender\n\nlet () =\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\n register_error_kind\n `Temporary\n ~id:\"operation.set_deposits_limit_when_automated_staking_off\"\n ~title:\"Set deposits limit when automated staking off\"\n ~description:\n \"Cannot set deposits limit when automated staking is off or Adaptive \\\n Issuance is active.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Cannot set a deposits limit when automated staking off.\")\n Data_encoding.unit\n (function\n | Set_deposits_limit_when_automated_staking_off -> Some () | _ -> None)\n (fun () -> Set_deposits_limit_when_automated_staking_off) ;\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:\"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:\"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 sender 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_sender\"\n ~title:\"Invalid sender for an internal operation\"\n ~description:\n \"Invalid sender for an internal operation restricted to implicit and \\\n originated accounts.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Invalid sender (%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_sender c -> Some c | _ -> None)\n (fun c -> Invalid_sender c) ;\n let invalid_self_transaction_destination_description =\n \"A pseudo-transaction destination must equal its sender.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operations.invalid_self_transaction_destination\"\n ~title:\"Invalid destination for a pseudo-transaction\"\n ~description:invalid_self_transaction_destination_description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n invalid_self_transaction_destination_description)\n Data_encoding.unit\n (function Invalid_self_transaction_destination -> Some () | _ -> None)\n (fun () -> Invalid_self_transaction_destination) ;\n let staking_for_delegator_while_external_staking_disabled_description =\n \"As long as external staking is not enabled, staking operations are only \\\n allowed from delegates.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operations.staking_for_delegator_while_external_staking_disabled\"\n ~title:\"Staking for a delegator while external staking is disabled\"\n ~description:\n staking_for_delegator_while_external_staking_disabled_description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n staking_for_delegator_while_external_staking_disabled_description)\n Data_encoding.unit\n (function\n | Staking_for_delegator_while_external_staking_disabled -> Some ()\n | _ -> None)\n (fun () -> Staking_for_delegator_while_external_staking_disabled) ;\n let stake_modification_without_delegate_description =\n \"(Un)Stake operations are only allowed when delegate is set.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operations.stake_modification_with_no_delegate_set\"\n ~title:\"(Un)staking without any delegate set\"\n ~description:stake_modification_without_delegate_description\n ~pp:(fun ppf () ->\n Format.pp_print_string ppf stake_modification_without_delegate_description)\n Data_encoding.unit\n (function Stake_modification_with_no_delegate_set -> Some () | _ -> None)\n (fun () -> Stake_modification_with_no_delegate_set) ;\n let staking_to_delegate_that_refuses_external_staking_description =\n \"The delegate currently does not accept staking operations from sources \\\n other than itself: its `limit_of_staking_over_baking` parameter is set to \\\n 0.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operations.staking_to_delegate_that_refuses_external_staking\"\n ~title:\"Staking to delegate that does not accept external staking\"\n ~description:staking_to_delegate_that_refuses_external_staking_description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n staking_to_delegate_that_refuses_external_staking_description)\n Data_encoding.unit\n (function\n | Staking_to_delegate_that_refuses_external_staking -> Some () | _ -> None)\n (fun () -> Staking_to_delegate_that_refuses_external_staking) ;\n register_error_kind\n `Permanent\n ~id:\"operations.invalid_nonzero_transaction_amount\"\n ~title:\"Invalid non-zero transaction amount\"\n ~description:\"A transaction expected a zero-amount but got non-zero.\"\n ~pp:(fun ppf amount ->\n Format.fprintf\n ppf\n \"A transaction expected a zero-amount but got %a.\"\n Tez.pp\n amount)\n Data_encoding.(obj1 (req \"amount\" Tez.encoding))\n (function\n | Invalid_nonzero_transaction_amount amount -> Some amount | _ -> None)\n (fun amount -> Invalid_nonzero_transaction_amount amount) ;\n register_error_kind\n `Permanent\n ~id:\"operations.invalid_staking_parameters_sender\"\n ~title:\"Invalid staking parameters sender\"\n ~description:\"The staking parameters can only be set by delegates.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Invalid staking parameters sender\")\n Data_encoding.empty\n (function Invalid_staking_parameters_sender -> Some () | _ -> None)\n (fun () -> Invalid_staking_parameters_sender)\n\nopen Apply_results\nopen Apply_operation_result\nopen Apply_internal_results\n\nlet update_script_storage_and_ticket_balances ctxt ~self_contract storage\n lazy_storage_diff ticket_diffs operations =\n let open Lwt_result_syntax in\n let* ctxt =\n Contract.update_script_storage ctxt self_contract storage lazy_storage_diff\n in\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 ~(sender : Contract.t) ~delegate ~before_operation =\n let open Lwt_result_syntax in\n let* ctxt, balance_updates =\n match sender with\n | Originated _ ->\n (* Originated contracts have no stake (yet). *)\n return (ctxt, [])\n | Implicit sender_pkh -> (\n let* sender_delegate_status =\n Contract.get_delegate_status ctxt sender_pkh\n in\n match sender_delegate_status with\n | Undelegated | Delegate ->\n (* No delegate before or re-activation: no unstake request added. *)\n return (ctxt, [])\n | Delegated delegate ->\n (* [request_unstake] bounds to the actual stake. *)\n Staking.request_unstake\n ctxt\n ~sender_contract:sender\n ~delegate\n Tez.max_mutez)\n in\n let+ ctxt = Contract.Delegate.set ctxt sender delegate in\n (ctxt, Gas.consumed ~since:before_operation ~until:ctxt, balance_updates, [])\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 ~sender ~amount ~pkh ~before_operation =\n let contract = Contract.Implicit pkh in\n let open Lwt_result_syntax in\n (* Transfers of zero to implicit accounts are forbidden. *)\n let*? () = error_when Tez.(amount = zero) (Empty_transaction contract) in\n (* If the implicit contract is not yet allocated at this point then\n the next transfer of tokens will allocate it. *)\n let*! already_allocated = Contract.allocated ctxt contract in\n let* ctxt, balance_updates =\n Token.transfer ctxt (`Contract sender) (`Contract contract) amount\n in\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 apply_stake ~ctxt ~sender ~amount ~destination ~before_operation =\n let open Lwt_result_syntax in\n let contract = Contract.Implicit destination in\n (* Staking of zero is forbidden. *)\n let*? () = error_when Tez.(amount = zero) (Empty_transaction contract) in\n let*? () =\n error_unless\n Signature.Public_key_hash.(sender = destination)\n Invalid_self_transaction_destination\n in\n let*? ctxt = Gas.consume ctxt Adaptive_issuance_costs.stake_cost in\n let* delegate_opt = Contract.Delegate.find ctxt contract in\n match delegate_opt with\n | None -> tzfail Stake_modification_with_no_delegate_set\n | Some delegate ->\n let allowed =\n Signature.Public_key_hash.(delegate = sender)\n || Constants.adaptive_issuance_enable ctxt\n in\n let*? () =\n error_unless\n allowed\n Staking_for_delegator_while_external_staking_disabled\n in\n let* {limit_of_staking_over_baking_millionth; _} =\n Delegate.Staking_parameters.of_delegate ctxt delegate\n in\n let forbidden =\n Signature.Public_key_hash.(delegate <> sender)\n && Compare.Int32.(limit_of_staking_over_baking_millionth = 0l)\n in\n let*? () =\n error_when forbidden Staking_to_delegate_that_refuses_external_staking\n in\n let* ctxt, balance_updates =\n Staking.stake ctxt ~amount:(`Exactly amount) ~sender ~delegate\n in\n (* Since [delegate] is an already existing delegate, it is already allocated. *)\n let allocated_destination_contract = false in\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;\n }\n in\n return (ctxt, result, [])\n\nlet apply_unstake ~ctxt ~sender ~amount ~destination ~before_operation =\n let open Lwt_result_syntax in\n let*? () =\n error_unless\n Signature.Public_key_hash.(sender = destination)\n Invalid_self_transaction_destination\n in\n let sender_contract = Contract.Implicit sender in\n let*? ctxt = Gas.consume ctxt Adaptive_issuance_costs.find_delegate_cost in\n let* delegate_opt = Contract.Delegate.find ctxt sender_contract in\n match delegate_opt with\n | None -> tzfail Stake_modification_with_no_delegate_set\n | Some delegate ->\n let* ctxt, balance_updates =\n Staking.request_unstake ctxt ~sender_contract ~delegate amount\n in\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 = false;\n }\n in\n return (ctxt, result, [])\n\nlet apply_finalize_unstake ~ctxt ~sender ~amount ~destination ~before_operation\n =\n let open Lwt_result_syntax in\n let*? () =\n error_when Tez.(amount <> zero) (Invalid_nonzero_transaction_amount amount)\n in\n let*? () =\n error_unless\n Signature.Public_key_hash.(sender = destination)\n Invalid_self_transaction_destination\n in\n let contract = Contract.Implicit sender in\n let*? ctxt = Gas.consume ctxt Adaptive_issuance_costs.find_delegate_cost in\n let*! already_allocated = Contract.allocated ctxt contract in\n let* ctxt, balance_updates = Staking.finalize_unstake ctxt contract in\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 apply_set_delegate_parameters ~ctxt ~sender ~destination\n ~limit_of_staking_over_baking_millionth\n ~edge_of_baking_over_staking_billionth ~before_operation =\n let open Lwt_result_syntax in\n let*? ctxt =\n Gas.consume ctxt Adaptive_issuance_costs.set_delegate_parameters_cost\n in\n let*? () =\n error_unless\n Signature.Public_key_hash.(sender = destination)\n Invalid_self_transaction_destination\n in\n let* is_delegate = Contract.is_delegate ctxt sender in\n let*? () = error_unless is_delegate Invalid_staking_parameters_sender in\n let*? t =\n Staking_parameters_repr.make\n ~limit_of_staking_over_baking_millionth\n ~edge_of_baking_over_staking_billionth\n in\n let* ctxt = Delegate.Staking_parameters.register_update ctxt sender t in\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 = false;\n }\n in\n return (ctxt, result, [])\n\nlet transfer_from_any_address ctxt sender destination amount =\n let open Lwt_result_syntax in\n match sender with\n | Destination.Contract sender ->\n Token.transfer ctxt (`Contract sender) (`Contract destination) amount\n | Destination.Sc_rollup _ | Destination.Zk_rollup _ ->\n (* We do not allow transferring tez from rollups to other contracts. *)\n let*? () =\n error_unless Tez.(amount = zero) (Non_empty_transaction_from sender)\n in\n return (ctxt, [])\n\nlet apply_transaction_to_implicit_with_ticket ~sender ~destination ~ty ~ticket\n ~amount ~before_operation ctxt =\n let open Lwt_result_syntax in\n let destination = Contract.Implicit destination in\n let*! already_allocated = Contract.allocated ctxt destination in\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 let* ticket_token, ctxt = Ticket_token_unparser.unparse ctxt ex_token in\n let* ctxt, balance_updates =\n transfer_from_any_address ctxt sender destination amount\n in\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 ~sender ~contract_hash ~amount\n ~entrypoint ~before_operation ~payer ~chain_id ~internal ~parameter ~script\n ~script_ir ~cache_key ?(paid_storage_diff_acc = Z.zero)\n ?(ticket_receipt_acc = []) () =\n let open Lwt_result_syntax in\n let contract = Contract.Originated contract_hash in\n (* We can assume the destination contract is already allocated at this point.\n If the destination contract does not exist, [Script_cache.find],\n which is called earlier, would have failed. *)\n let* ctxt, balance_updates =\n transfer_from_any_address ctxt sender contract amount\n in\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 let* balance = Contract.get_balance ctxt contract in\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 {sender; payer; self = contract_hash; amount; chain_id; balance; now; level}\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 let* ( {\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 execute\n ctxt\n ~cached_script\n Optimized\n step_constants\n ~script\n ~entrypoint\n ~internal\n in\n let* ticket_table_size_diff, 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 in\n let* ticket_paid_storage_diff, ctxt =\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:ticket_table_size_diff\n in\n let* ctxt, new_size, contract_paid_storage_size_diff =\n Fees.record_paid_storage_space ctxt contract_hash\n in\n let* originated_contracts =\n Contract.originated_from_current_nonce ~since:before_operation ~until:ctxt\n in\n let*? ctxt =\n Script_cache.update\n ctxt\n cache_key\n ({script with storage = Script.lazy_expr storage}, updated_cached_script)\n updated_size\n in\n let result =\n Transaction_to_contract_result\n {\n storage = Some storage;\n lazy_storage_diff;\n balance_updates;\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/6639\n Currently, if both [ticket_receipt_acc] and [ticket_receipt] contain updates\n for the same ticket token, the token will appear in a non-optimal, but not wrong,\n way in the ticket receipt. See description of #6639 for an example. *)\n ticket_receipt = ticket_receipt_acc @ 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.(\n add\n paid_storage_diff_acc\n (add contract_paid_storage_size_diff ticket_paid_storage_diff));\n allocated_destination_contract = false;\n }\n in\n return (ctxt, result, operations)\n\nlet apply_origination ~ctxt ~storage_type ~storage ~unparsed_code\n ~contract:contract_hash ~delegate ~sender ~credit ~before_operation =\n let open Lwt_result_syntax in\n let*? to_duplicate, ctxt =\n Script_ir_translator.collect_lazy_storage ctxt storage_type storage\n in\n let to_update = Script_ir_translator.no_lazy_storage_id in\n let* storage, lazy_storage_diff, ctxt =\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 in\n let* storage, ctxt =\n Script_ir_translator.unparse_data ctxt Optimized storage_type storage\n in\n let storage = Script.lazy_expr storage in\n (* Normalize code to avoid #843 *)\n let* code, ctxt =\n Script_ir_translator.unparse_code\n ctxt\n Optimized\n (Micheline.root unparsed_code)\n in\n let code = Script.lazy_expr code in\n let script = {Script.code; storage} in\n let* ctxt =\n Contract.raw_originate\n ctxt\n ~prepaid_bootstrap_storage:false\n contract_hash\n ~script:(script, lazy_storage_diff)\n in\n let contract = Contract.Originated contract_hash in\n let* ctxt =\n match delegate with\n | None -> return ctxt\n | Some delegate -> Contract.Delegate.init ctxt contract delegate\n in\n let* ctxt, balance_updates =\n Token.transfer ctxt (`Contract sender) (`Contract contract) credit\n in\n let+ ctxt, size, paid_storage_size_diff =\n Fees.record_paid_storage_space ctxt contract_hash\n in\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 script 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_sender_is_contract =\n let open Result_syntax in\n function\n | Destination.Contract sender -> return sender\n | sender -> tzfail (Invalid_sender sender)\n\nlet find_contract_from_cache ctxt contract_hash =\n let open Lwt_result_syntax in\n let* ctxt, cache_key, script = Script_cache.find ctxt contract_hash in\n match script with\n | None -> tzfail (Contract.Non_existing_contract (Originated contract_hash))\n | Some (script, script_ir) -> return (ctxt, (cache_key, script, script_ir))\n\nlet apply_internal_operation_contents :\n type kind.\n context ->\n payer:public_key_hash ->\n sender: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 let open Lwt_result_syntax in\n fun ctxt_before_op ~payer ~sender ~chain_id operation ->\n let* ctxt = Destination.must_exist ctxt_before_op sender in\n (* There is no signature being checked for internal operations so in\n this case the fixed cost is exactly\n [Michelson_v1_gas.Cost_of.manager_operation]. *)\n let*? ctxt = Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation in\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 let*? sender = assert_sender_is_contract sender in\n let+ ctxt, res, ops =\n apply_transaction_to_implicit\n ~ctxt\n ~sender\n ~amount\n ~pkh\n ~before_operation:ctxt_before_op\n in\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 let+ ctxt, res, ops =\n apply_transaction_to_implicit_with_ticket\n ~sender\n ~destination\n ~ty\n ~ticket\n ~amount\n ~before_operation:ctxt_before_op\n ctxt\n in\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 let* ctxt, (cache_key, script, script_ir) =\n find_contract_from_cache ctxt contract_hash\n in\n let+ ctxt, res, ops =\n apply_transaction_to_smart_contract\n ~ctxt\n ~sender\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 ~script\n ~script_ir\n ~cache_key\n ()\n in\n (ctxt, ITransaction_result res, ops)\n | Transaction_to_sc_rollup\n {\n destination;\n entrypoint = _;\n parameters_ty;\n parameters;\n unparsed_parameters = payload;\n } ->\n let*? sender =\n match sender with\n | Destination.Contract (Originated hash) -> Ok hash\n | _ -> Result_syntax.tzfail Invalid_transfer_to_sc_rollup\n in\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 let* ctxt =\n Sc_rollup.Inbox.add_deposit\n ctxt\n ~destination\n ~payload\n ~sender\n ~source:payer\n in\n let*? has_tickets, ctxt =\n Ticket_scanner.type_has_tickets ctxt parameters_ty\n in\n let* ticket_token_map, ctxt =\n Ticket_accounting.ticket_balances_of_value\n ctxt\n ~include_lazy:true\n has_tickets\n parameters\n in\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 let+ ticket_receipt, ctxt =\n Ticket_token_map.fold_es\n ctxt\n (fun ctxt acc ex_token amount ->\n let* ticket_token, ctxt =\n Ticket_token_unparser.unparse ctxt ex_token\n in\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 in\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 let*? sender = assert_sender_is_contract sender in\n let+ ctxt, origination_result, ops =\n apply_origination\n ~ctxt\n ~storage_type\n ~storage\n ~unparsed_code\n ~contract:preorigination\n ~delegate\n ~sender\n ~credit\n ~before_operation:ctxt_before_op\n in\n (ctxt, IOrigination_result origination_result, ops)\n | Delegation delegate ->\n let*? sender = assert_sender_is_contract sender in\n let+ ctxt, consumed_gas, balance_updates, ops =\n apply_delegation\n ~ctxt\n ~sender\n ~delegate\n ~before_operation:ctxt_before_op\n in\n (ctxt, IDelegation_result {consumed_gas; balance_updates}, ops)\n\nlet apply_manager_operation :\n type kind.\n context ->\n source:public_key_hash ->\n chain_id:Chain_id.t ->\n consume_gas_for_sig_check:Gas.cost option ->\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 let open Lwt_result_syntax in\n fun ctxt_before_op ~source ~chain_id ~consume_gas_for_sig_check operation ->\n let source_contract = Contract.Implicit source in\n (* See the comment above [fixed_gas_cost] in the\n {!Validate.check_contents} function. *)\n let fixed_gas_cost =\n let manager_op_cost = Michelson_v1_gas.Cost_of.manager_operation in\n match consume_gas_for_sig_check with\n | None -> manager_op_cost\n | Some gas_for_sig_check -> Gas.(manager_op_cost +@ gas_for_sig_check)\n in\n let*? ctxt = Gas.consume ctxt_before_op fixed_gas_cost in\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 let* () = Contract.must_be_allocated ctxt source_contract in\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 let* ctxt =\n Contract.reveal_manager_key ~check_consistency:false ctxt source pk\n in\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 ->\n let*? parameters, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n parameters\n in\n let elab_conf = Script_ir_translator_config.make ~legacy:false () in\n let+ ctxt, res, ops =\n match Entrypoint.to_string entrypoint with\n | \"default\" ->\n let* () =\n fail_unless\n (Script.is_unit parameters)\n (Script_interpreter.Bad_contract_parameter source_contract)\n in\n apply_transaction_to_implicit\n ~ctxt\n ~sender:source_contract\n ~amount\n ~pkh\n ~before_operation:ctxt_before_op\n | \"stake\" ->\n let* () =\n fail_unless\n (Script.is_unit parameters)\n (Script_interpreter.Bad_contract_parameter source_contract)\n in\n let*? () = Staking.check_manual_staking_allowed ctxt in\n apply_stake\n ~ctxt\n ~sender:source\n ~amount\n ~destination:pkh\n ~before_operation:ctxt_before_op\n | \"unstake\" ->\n let* () =\n fail_unless\n (Script.is_unit parameters)\n (Script_interpreter.Bad_contract_parameter source_contract)\n in\n let*? () = Staking.check_manual_staking_allowed ctxt in\n apply_unstake\n ~ctxt\n ~sender:source\n ~amount\n ~destination:pkh\n ~before_operation:ctxt_before_op\n | \"finalize_unstake\" ->\n let* () =\n fail_unless\n (Script.is_unit parameters)\n (Script_interpreter.Bad_contract_parameter source_contract)\n in\n apply_finalize_unstake\n ~ctxt\n ~sender:source\n ~amount\n ~destination:pkh\n ~before_operation:ctxt_before_op\n | \"set_delegate_parameters\" ->\n let* ( ( limit_of_staking_over_baking_millionth,\n (edge_of_baking_over_staking_billionth, ()) ),\n ctxt ) =\n Script_ir_translator.parse_data\n ~elab_conf\n ctxt\n ~allow_forged_tickets:false\n ~allow_forged_lazy_storage_id:false\n Script_typed_ir.pair_int_int_unit_t\n (Micheline.root parameters)\n in\n apply_set_delegate_parameters\n ~ctxt\n ~sender:source\n ~destination:pkh\n ~limit_of_staking_over_baking_millionth:\n (Script_int.to_zint limit_of_staking_over_baking_millionth)\n ~edge_of_baking_over_staking_billionth:\n (Script_int.to_zint edge_of_baking_over_staking_billionth)\n ~before_operation:ctxt_before_op\n | _ -> tzfail (Script_tc_errors.No_such_entrypoint entrypoint)\n in\n (ctxt, Transaction_result res, ops)\n | Transaction\n {amount; parameters; destination = Originated contract_hash; entrypoint}\n ->\n let*? parameters, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n parameters\n in\n let* ctxt, (cache_key, script, script_ir) =\n find_contract_from_cache ctxt contract_hash\n in\n let+ ctxt, res, ops =\n if not @@ Constants.direct_ticket_spending_enable ctxt then\n apply_transaction_to_smart_contract\n ~ctxt\n ~sender:(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 ~script\n ~script_ir\n ~cache_key\n ()\n else\n let (Ex_script (Script {arg_type; entrypoints; _})) = script_ir in\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 let* typed_arg, ctxt =\n Script_ir_translator.parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged_tickets:true\n ~allow_forged_lazy_storage_id:false\n parameters_ty\n (Micheline.root parameters)\n in\n let* ctxt, ticket_receipt, paid_storage_diff =\n Ticket_transfer.transfer_tickets_in_parameters\n ctxt\n typed_arg\n parameters_ty\n ~source:(Contract source_contract)\n ~dst:(Contract (Originated contract_hash))\n in\n apply_transaction_to_smart_contract\n ~ctxt\n ~sender:(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:\n (Typed_arg (Micheline.dummy_location, parameters_ty, typed_arg))\n ~script\n ~script_ir\n ~cache_key\n ~ticket_receipt_acc:ticket_receipt\n ~paid_storage_diff_acc:paid_storage_diff\n ()\n in\n (ctxt, Transaction_result res, ops)\n | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint}\n -> (\n match destination with\n | Implicit _ ->\n let*? () =\n error_unless\n Entrypoint.(entrypoint = default)\n (Script_tc_errors.No_such_entrypoint entrypoint)\n in\n let* ctxt, ticket =\n Ticket_transfer.parse_ticket\n ~consume_deserialization_gas\n ~ticketer\n ~contents\n ~ty\n ctxt\n in\n let* ctxt, paid_storage_size_diff =\n Ticket_transfer.transfer_ticket\n ctxt\n ~sender:(Contract source_contract)\n ~dst:(Contract destination)\n ticket\n amount\n in\n let* ticket_token, ctxt =\n Ticket_token_unparser.unparse ctxt ticket\n in\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 {\n account = Contract source_contract;\n amount = Z.neg amount;\n };\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 =\n Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n paid_storage_size_diff;\n },\n [] )\n | Originated destination_hash ->\n let* ctxt, token, op =\n Ticket_transfer.parse_ticket_and_operation\n ~consume_deserialization_gas\n ~ticketer\n ~contents\n ~ty\n ~sender:(Destination.Contract source_contract)\n ~destination:destination_hash\n ~entrypoint\n ~amount\n ctxt\n in\n let* ctxt, paid_storage_size_diff =\n Ticket_transfer.transfer_ticket\n ctxt\n ~sender:(Contract source_contract)\n ~dst:(Contract destination)\n token\n amount\n in\n let* ticket_token, ctxt =\n Ticket_token_unparser.unparse ctxt token\n in\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 {\n account = Contract source_contract;\n amount = Z.neg amount;\n }\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 =\n 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 let*? ctxt, contract =\n Contract.fresh_contract_from_current_nonce ctxt\n in\n let*? _unparsed_storage, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n script.Script.storage\n in\n let*? unparsed_code, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n script.Script.code\n in\n let* Ex_script parsed_script, ctxt =\n Script_ir_translator.parse_script\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged_tickets_in_storage:false\n ~allow_forged_lazy_storage_id_in_storage:false\n script\n in\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 let* _typed_views, ctxt =\n trace\n (Script_tc_errors.Ill_typed_contract (unparsed_code, []))\n views_result\n in\n let+ ctxt, origination_result, ops =\n apply_origination\n ~ctxt\n ~storage_type\n ~storage\n ~unparsed_code\n ~contract\n ~delegate\n ~sender:source_contract\n ~credit\n ~before_operation:ctxt_before_op\n in\n (ctxt, Origination_result origination_result, ops)\n | Delegation delegate ->\n let+ ctxt, consumed_gas, balance_updates, ops =\n apply_delegation\n ~ctxt\n ~sender:source_contract\n ~delegate\n ~before_operation:ctxt_before_op\n in\n (ctxt, Delegation_result {consumed_gas; balance_updates}, ops)\n | Register_global_constant {value} ->\n (* Decode the value and consume gas appropriately *)\n let*? expr, ctxt =\n Script.force_decode_in_context ~consume_deserialization_gas ctxt value\n in\n (* Set the key to the value in storage. *)\n let* ctxt, address, size =\n Global_constants_storage.register ctxt expr\n in\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 let*! is_registered = Delegate.registered ctxt source in\n let*? () =\n error_unless\n is_registered\n (Set_deposits_limit_on_unregistered_delegate source)\n in\n let is_autostaking_enabled =\n match Staking.staking_automation ctxt with\n | Manual_staking -> false\n | Auto_staking -> true\n in\n let*? () =\n error_unless\n is_autostaking_enabled\n Set_deposits_limit_when_automated_staking_off\n in\n let*! ctxt = Delegate.set_frozen_deposits_limit ctxt source limit in\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 let* ctxt =\n Contract.increase_paid_storage ctxt destination ~amount_in_bytes\n in\n let payer = `Contract (Contract.Implicit source) in\n let+ ctxt, storage_bus =\n Fees.burn_storage_increase_fees ctxt ~payer amount_in_bytes\n in\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 let*! is_registered = Delegate.registered ctxt source in\n let*? () =\n error_unless\n is_registered\n (Update_consensus_key_on_unregistered_delegate source)\n in\n let* ctxt = Delegate.Consensus_key.register_update ctxt source pk in\n return\n ( ctxt,\n Update_consensus_key_result\n {consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt},\n [] )\n | Dal_publish_commitment slot_header ->\n let*? ctxt, slot_header =\n Dal_apply.apply_publish_commitment ctxt slot_header\n in\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Dal_publish_commitment_result {slot_header; consumed_gas}\n in\n return (ctxt, result, [])\n | Sc_rollup_originate {kind; boot_sector; parameters_ty; whitelist} ->\n let* {address; size; genesis_commitment_hash}, ctxt =\n Sc_rollup_operations.originate\n ctxt\n ~kind\n ~boot_sector\n ~parameters_ty\n ?whitelist\n in\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 let* ctxt = Sc_rollup.Inbox.add_external_messages ctxt messages in\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} ->\n let* ctxt, commitment, commitment_hash =\n Sc_rollup.Stake_storage.cement_commitment ctxt rollup\n in\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_cement_result\n {\n consumed_gas;\n inbox_level = commitment.inbox_level;\n commitment_hash;\n }\n in\n return (ctxt, result, [])\n | Sc_rollup_publish {rollup; commitment} ->\n let* staked_hash, published_at_level, ctxt, balance_updates =\n Sc_rollup.Stake_storage.publish_commitment\n ctxt\n rollup\n source\n commitment\n in\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 let* game_result, ctxt =\n match refutation with\n | Start {player_commitment_hash; opponent_commitment_hash} ->\n let* ctxt =\n start_game\n ctxt\n rollup\n ~player:(player, player_commitment_hash)\n ~opponent:(opponent, opponent_commitment_hash)\n in\n return (None, ctxt)\n | Move {step; choice} ->\n game_move ctxt rollup ~player ~opponent ~step ~choice\n in\n let* game_status, ctxt, balance_updates =\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 in\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 let* game_result, ctxt =\n Sc_rollup.Refutation_storage.timeout ctxt rollup stakers\n in\n let* game_status, ctxt, balance_updates =\n Sc_rollup.Refutation_storage.apply_game_result\n ctxt\n rollup\n stakers\n game_result\n in\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\n {rollup; cemented_commitment; output_proof} ->\n let+ ( {\n Sc_rollup_operations.paid_storage_size_diff;\n ticket_receipt;\n whitelist_update;\n operations;\n },\n ctxt ) =\n Sc_rollup_operations.execute_outbox_message\n ctxt\n rollup\n ~cemented_commitment\n ~output_proof\n in\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 whitelist_update;\n balance_updates = [];\n consumed_gas;\n }\n in\n (ctxt, result, operations)\n | Sc_rollup_recover_bond {sc_rollup; staker} ->\n let* ctxt, balance_updates =\n Sc_rollup.Stake_storage.withdraw_stake ctxt sc_rollup staker\n in\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\n {public_parameters; circuits_info; init_state; nb_ops} ->\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 open Lwt_syntax in\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 ({sender; operation; nonce} as op)\n :: rest -> (\n let* result =\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 ~sender\n ~payer\n ~chain_id\n operation\n in\n match result with\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 let open Lwt_result_syntax in\n match trr with\n | Transaction_to_contract_result payload ->\n let consumed = payload.paid_storage_size_diff in\n let* ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\n let* ctxt, storage_limit, origination_bus =\n if payload.allocated_destination_contract then\n Fees.burn_origination_fees ctxt ~storage_limit ~payer\n else return (ctxt, storage_limit, [])\n in\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_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 let* ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\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 open Lwt_result_syntax in\n let consumed = paid_storage_size_diff in\n let* ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\n let* ctxt, storage_limit, origination_bus =\n Fees.burn_origination_fees ctxt ~storage_limit ~payer\n in\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 let open Lwt_result_syntax in\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 let+ ctxt, storage_limit, transaction_result =\n burn_transaction_storage_fees\n ctxt\n transaction_result\n ~storage_limit\n ~payer\n in\n (ctxt, storage_limit, Transaction_result transaction_result)\n | Origination_result origination_result ->\n let+ ctxt, storage_limit, origination_result =\n burn_origination_storage_fees\n ctxt\n origination_result\n ~storage_limit\n ~payer\n in\n (ctxt, storage_limit, Origination_result origination_result)\n | Reveal_result _ | Delegation_result _ ->\n return (ctxt, storage_limit, smopr)\n | Register_global_constant_result payload ->\n let consumed = payload.size_of_constant in\n let+ ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\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 | Transfer_ticket_result payload ->\n let consumed = payload.paid_storage_size_diff in\n let+ ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\n let balance_updates = payload.balance_updates @ storage_bus in\n ( ctxt,\n storage_limit,\n Transfer_ticket_result {payload with balance_updates} )\n | Dal_publish_commitment_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_originate_result payload ->\n let+ ctxt, storage_limit, balance_updates =\n Fees.burn_sc_rollup_origination_fees\n ctxt\n ~storage_limit\n ~payer\n payload.size\n in\n let result =\n Sc_rollup_originate_result {payload with balance_updates}\n 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 let+ ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\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 let* ctxt, storage_limit, balance_updates =\n Fees.burn_zk_rollup_origination_fees\n ctxt\n ~storage_limit\n ~payer\n payload.storage_size\n in\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 let+ ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\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 let+ ctxt, storage_limit, storage_bus =\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n in\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 let open Lwt_result_syntax in\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 let+ ctxt, storage_limit, transaction_result =\n burn_transaction_storage_fees\n ctxt\n transaction_result\n ~storage_limit\n ~payer\n in\n (ctxt, storage_limit, ITransaction_result transaction_result)\n | IOrigination_result origination_result ->\n let+ ctxt, storage_limit, origination_result =\n burn_origination_storage_fees\n ctxt\n origination_result\n ~storage_limit\n ~payer\n in\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 ~consume_gas_for_sig_check\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 open Lwt_result_syntax in\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 let*! result =\n apply_manager_operation\n ctxt\n ~source\n ~chain_id\n ~consume_gas_for_sig_check\n operation\n in\n match result with\n | Ok (ctxt, operation_results, internal_operations) -> (\n let*! result =\n apply_internal_operations\n ctxt\n ~payer:source\n ~chain_id\n internal_operations\n in\n match result with\n | Success ctxt, internal_operations_results -> (\n let*! result =\n burn_manager_storage_fees\n ctxt\n operation_results\n ~storage_limit\n ~payer:source\n in\n match result with\n | Ok (ctxt, storage_limit, operation_results) ->\n let*! result =\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 let* ctxt, storage_limit, smopr =\n burn_internal_storage_fees\n ctxt\n smopr\n ~storage_limit\n ~payer:source\n in\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 in\n Lwt.return\n (match result with\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 consume_gas_for_sig_check:Gas.cost option ->\n kind Kind.manager fees_updated_contents_list ->\n (success_or_failure * kind Kind.manager contents_result_list) Lwt.t =\n let open Lwt_syntax in\n fun ctxt\n ~payload_producer\n chain_id\n ~consume_gas_for_sig_check\n 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 ->\n let+ ctxt_result, operation_result, internal_operation_results =\n apply_manager_contents ctxt chain_id ~consume_gas_for_sig_check op\n in\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 let* result =\n apply_manager_contents ctxt chain_id ~consume_gas_for_sig_check op\n in\n match result with\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 )\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 let+ ctxt_result, results =\n apply_manager_contents_list_rec\n ctxt\n ~payload_producer\n chain_id\n ~consume_gas_for_sig_check:None\n rest\n in\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 {predecessor_fitness : Fitness.raw}\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 : Per_block_votes.Liquidity_baking_toggle_EMA.t;\n adaptive_issuance_vote_ema : Per_block_votes.Adaptive_issuance_launch_EMA.t;\n adaptive_issuance_launch_cycle : Cycle.t option;\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 (Preattestation _) -> ctxt\n | Single (Attestation _) -> ctxt\n | Single\n ( Failing_noop _ | Proposals _ | Ballot _ | Seed_nonce_revelation _\n | Vdf_revelation _ | Double_attestation_evidence _\n | Double_preattestation_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 find_in_slot_map slot slot_map =\n let open Result_syntax in\n match slot_map with\n | None -> tzfail (Consensus.Slot_map_not_found {loc = __LOC__})\n | Some slot_map -> (\n match Slot.Map.find slot slot_map with\n | None ->\n (* This should not happen: operation validation should have failed. *)\n tzfail Faulty_validation_wrong_slot\n | Some (consensus_key, power, dal_power) ->\n return (consensus_key, power, dal_power))\n\nlet record_preattestation ctxt (mode : mode) (content : consensus_content) :\n (context * Kind.preattestation contents_result_list) tzresult Lwt.t =\n let open Lwt_result_syntax in\n let ctxt =\n match mode with\n | Full_construction _ -> (\n match Consensus.get_preattestations_quorum_round ctxt with\n | None -> Consensus.set_preattestations_quorum_round ctxt content.round\n | Some _ -> ctxt)\n | Application _ | Partial_construction _ -> ctxt\n in\n let mk_preattestation_result ({delegate; consensus_pkh; _} : Consensus_key.pk)\n consensus_power =\n Single_result\n (Preattestation_result\n {\n balance_updates = [];\n delegate;\n consensus_key = consensus_pkh;\n consensus_power;\n })\n in\n match mode with\n | Application _ | Full_construction _ ->\n let*? consensus_key, power, _dal_power =\n find_in_slot_map content.slot (Consensus.allowed_preattestations ctxt)\n in\n let*? ctxt =\n Consensus.record_preattestation\n ctxt\n ~initial_slot:content.slot\n ~power\n content.round\n in\n return (ctxt, mk_preattestation_result consensus_key power)\n | Partial_construction _ ->\n (* In mempool mode, preattestations are allowed for various levels\n and rounds. We do not record preattestations because we could get\n false-positive conflicts for preattestations with the same slot\n but different levels/rounds. We could record just preattestations\n for the mempool head's level and round (the most usual\n preattestations), but we don't need to, because there is no block\n to finalize anyway in this mode. *)\n let* ctxt, consensus_key =\n let level = Level.from_raw ctxt content.level in\n Stake_distribution.slot_owner ctxt level content.slot\n in\n return (ctxt, mk_preattestation_result consensus_key 0 (* Fake power. *))\n\nlet record_attestation ctxt (mode : mode) (consensus : consensus_content)\n (dal : dal_content option) :\n (context * Kind.attestation contents_result_list) tzresult Lwt.t =\n let open Lwt_result_syntax in\n let mk_attestation_result ({delegate; consensus_pkh; _} : Consensus_key.pk)\n consensus_power =\n Single_result\n (Attestation_result\n {\n balance_updates = [];\n delegate;\n consensus_key = consensus_pkh;\n consensus_power;\n })\n in\n match mode with\n | Application _ | Full_construction _ ->\n let*? consensus_key, power, dal_power =\n find_in_slot_map consensus.slot (Consensus.allowed_attestations ctxt)\n in\n let*? ctxt =\n Consensus.record_attestation ctxt ~initial_slot:consensus.slot ~power\n in\n let*? ctxt =\n Option.fold\n ~none:(Result_syntax.return ctxt)\n ~some:(fun dal ->\n Dal_apply.apply_attestation ctxt dal.attestation ~power:dal_power)\n dal\n in\n return (ctxt, mk_attestation_result consensus_key power)\n | Partial_construction _ ->\n (* In mempool mode, attestations are allowed for various levels\n and rounds. We do not record attestations because we could get\n false-positive conflicts for attestations with the same slot\n but different levels/rounds. We could record just attestations\n for the predecessor's level and round (the most usual\n attestations), but we don't need to, because there is no block\n to finalize anyway in this mode. *)\n let* ctxt, consensus_key =\n let level = Level.from_raw ctxt consensus.level in\n Stake_distribution.slot_owner ctxt level consensus.slot\n in\n return (ctxt, mk_attestation_result consensus_key 0 (* Fake power. *))\n\nlet apply_manager_contents_list ctxt ~payload_producer chain_id\n ~gas_cost_for_sig_check fees_updated_contents_list =\n let open Lwt_syntax in\n let* ctxt_result, results =\n apply_manager_contents_list_rec\n ctxt\n ~payload_producer\n chain_id\n ~consume_gas_for_sig_check:(Some gas_cost_for_sig_check)\n fees_updated_contents_list\n in\n match ctxt_result with\n | Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results)\n | Success ctxt ->\n let+ ctxt = Lazy_storage.cleanup_temporaries ctxt in\n (ctxt, results)\n\nlet apply_manager_operations ctxt ~payload_producer chain_id ~mempool_mode\n ~source ~operation 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 gas_cost_for_sig_check =\n let algo =\n Michelson_v1_gas.Cost_of.Interpreter.algo_of_public_key_hash source\n in\n Operation_costs.check_signature_cost algo operation\n in\n let*! ctxt, contents_result_list =\n apply_manager_contents_list\n ctxt\n ~payload_producer\n chain_id\n ~gas_cost_for_sig_check\n fees_updated_contents_list\n in\n return (ctxt, contents_result_list)\n\nlet punish_delegate ctxt ~operation_hash delegate level misbehaviour mk_result\n ~payload_producer =\n let open Lwt_result_syntax in\n let rewarded = payload_producer.Consensus_key.delegate in\n let+ ctxt =\n Delegate.punish_double_signing\n ctxt\n ~operation_hash\n misbehaviour\n delegate\n level\n ~rewarded\n in\n (ctxt, Single_result (mk_result (Some delegate) []))\n\nlet punish_double_attestation_or_preattestation (type kind) ctxt ~operation_hash\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 open Lwt_result_syntax in\n let mk_result forbidden_delegate (balance_updates : Receipt.balance_updates) :\n kind Kind.double_consensus_operation_evidence contents_result =\n match op1.protocol_data.contents with\n | Single (Preattestation _) ->\n Double_preattestation_evidence_result\n {forbidden_delegate; balance_updates}\n | Single (Attestation _) ->\n Double_attestation_evidence_result {forbidden_delegate; balance_updates}\n in\n let {slot; level = raw_level; round; block_payload_hash = _}, kind =\n match op1.protocol_data.contents with\n | Single (Preattestation consensus_content) ->\n (consensus_content, Misbehaviour.Double_preattesting)\n | Single (Attestation {consensus_content; dal_content = _}) ->\n (consensus_content, Misbehaviour.Double_attesting)\n in\n let level = Level.from_raw ctxt raw_level in\n let* ctxt, consensus_pk1 = Stake_distribution.slot_owner ctxt level slot in\n punish_delegate\n ctxt\n ~operation_hash\n consensus_pk1.delegate\n level\n {level = raw_level; round; kind}\n mk_result\n ~payload_producer\n\nlet punish_double_baking ctxt ~operation_hash (bh1 : Block_header.t)\n ~payload_producer =\n let open Lwt_result_syntax in\n let*? bh1_fitness = Fitness.from_raw bh1.shell.fitness in\n let round1 = Fitness.round bh1_fitness in\n let*? raw_level = Raw_level.of_int32 bh1.shell.level in\n let level = Level.from_raw ctxt raw_level in\n let committee_size = Constants.consensus_committee_size ctxt in\n let*? slot1 = Round.to_slot round1 ~committee_size in\n let* ctxt, consensus_pk1 = Stake_distribution.slot_owner ctxt level slot1 in\n punish_delegate\n ctxt\n ~operation_hash\n consensus_pk1.delegate\n level\n {level = raw_level; round = round1; kind = Double_baking}\n ~payload_producer\n (fun forbidden_delegate balance_updates ->\n Double_baking_evidence_result {forbidden_delegate; balance_updates})\n\nlet apply_contents_list (type kind) ctxt chain_id (mode : mode)\n ~payload_producer ~operation ~operation_hash\n (contents_list : kind contents_list) :\n (context * kind contents_result_list) tzresult Lwt.t =\n let open Lwt_result_syntax in\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 (Preattestation consensus_content) ->\n record_preattestation ctxt mode consensus_content\n | Single (Attestation {consensus_content; dal_content}) ->\n record_attestation ctxt mode consensus_content dal_content\n | Single (Seed_nonce_revelation {level; nonce}) ->\n let level = Level.from_raw ctxt level in\n let* ctxt = Nonce.reveal ctxt level nonce in\n let*? tip = Delegate.Rewards.seed_nonce_revelation_tip ctxt in\n let delegate = payload_producer.Consensus_key.delegate in\n let+ ctxt, balance_updates =\n Delegate.Shared_stake.pay_rewards\n ctxt\n ~source:`Revelation_rewards\n ~delegate\n tip\n in\n (ctxt, Single_result (Seed_nonce_revelation_result balance_updates))\n | Single (Vdf_revelation {solution}) ->\n let* ctxt = Seed.update_seed ctxt solution in\n let*? tip = Delegate.Rewards.vdf_revelation_tip ctxt in\n let delegate = payload_producer.Consensus_key.delegate in\n let+ ctxt, balance_updates =\n Delegate.Shared_stake.pay_rewards\n ctxt\n ~source:`Revelation_rewards\n ~delegate\n tip\n in\n (ctxt, Single_result (Vdf_revelation_result balance_updates))\n | Single (Double_preattestation_evidence {op1; op2 = _}) ->\n punish_double_attestation_or_preattestation\n ctxt\n ~operation_hash\n ~op1\n ~payload_producer\n | Single (Double_attestation_evidence {op1; op2 = _}) ->\n punish_double_attestation_or_preattestation\n ctxt\n ~operation_hash\n ~op1\n ~payload_producer\n | Single (Double_baking_evidence {bh1; bh2 = _}) ->\n punish_double_baking ctxt ~operation_hash 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 sender = `Collected_commitments blinded_pkh in\n let contract = Contract.Implicit (Signature.Ed25519 pkh) in\n let* ctxt, amount = Token.balance ctxt sender in\n let* ctxt, bupds =\n Token.transfer ctxt sender (`Contract contract) amount\n in\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 let* ctxt, allocated_destination_contract, fees, drain_balance_updates =\n Delegate.drain ctxt ~delegate ~destination\n in\n let* ctxt, fees_balance_updates =\n Token.transfer\n ctxt\n (`Contract (Contract.Implicit delegate))\n (`Contract\n (Contract.Implicit payload_producer.Consensus_key.delegate))\n fees\n in\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 {source; _}) ->\n apply_manager_operations\n ctxt\n ~payload_producer\n chain_id\n ~mempool_mode\n ~source\n ~operation\n contents_list\n | Cons (Manager_operation {source; _}, _) ->\n apply_manager_operations\n ctxt\n ~payload_producer\n chain_id\n ~mempool_mode\n ~source\n ~operation\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\n ~operation_hash\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 let open Lwt_result_syntax in\n match Level.dawn_of_a_new_cycle ctxt with\n | None -> return (ctxt, [], [])\n | Some last_cycle ->\n let* ctxt, balance_updates, deactivated =\n Delegate.cycle_end ctxt last_cycle\n in\n let+ ctxt = Bootstrap.cycle_end ctxt last_cycle in\n (ctxt, balance_updates, deactivated)\n\nlet apply_liquidity_baking_subsidy ctxt ~per_block_vote =\n let open Lwt_result_syntax in\n Liquidity_baking.on_subsidy_allowed\n ctxt\n ~per_block_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*! result =\n let*? liquidity_baking_subsidy =\n Delegate.Rewards.liquidity_baking_subsidy ctxt\n in\n (* credit liquidity baking subsidy to CPMM contract *)\n let* ctxt, balance_updates =\n Token.transfer\n ~origin:Subsidy\n ctxt\n `Liquidity_baking_subsidies\n (`Contract liquidity_baking_cpmm_contract)\n liquidity_baking_subsidy\n in\n let* ctxt, cache_key, script =\n Script_cache.find ctxt liquidity_baking_cpmm_contract_hash\n in\n match script with\n | None ->\n 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 let* balance =\n Contract.get_balance ctxt liquidity_baking_cpmm_contract\n in\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 sender = 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 let* ( {\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 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 in\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 let* ticket_table_size_diff, ctxt =\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 in\n let* ctxt, new_size, paid_storage_size_diff =\n Fees.record_paid_storage_space\n ctxt\n liquidity_baking_cpmm_contract_hash\n in\n let* ticket_paid_storage_diff, ctxt =\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:ticket_table_size_diff\n in\n let consumed_gas =\n Gas.consumed ~since:backtracking_ctxt ~until:ctxt\n in\n let*? ctxt =\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 in\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 in\n return\n (match result with\n | Ok (ctxt, results) -> (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 (ctxt, [])))\n\nlet are_attestations_required ctxt ~level =\n let open Lwt_result_syntax in\n let+ first_level = First_level_of_protocol.get ctxt in\n (* NB: the first level is the level of the migration block. There\n are no attestations for this block. Therefore the block at the\n next level cannot contain attestations. *)\n let level_position_in_protocol = Raw_level.diff level first_level in\n Compare.Int32.(level_position_in_protocol > 1l)\n\nlet record_attesting_participation ctxt =\n match Consensus.allowed_attestations ctxt with\n | None -> tzfail (Consensus.Slot_map_not_found {loc = __LOC__})\n | Some validators ->\n Slot.Map.fold_es\n (fun initial_slot\n ((consensus_pk : Consensus_key.pk), power, _dal_power)\n ctxt ->\n let participation =\n if Slot.Set.mem initial_slot (Consensus.attestations_seen ctxt) then\n Delegate.Participated\n else Delegate.Didn't_participate\n in\n Delegate.record_attesting_participation\n ctxt\n ~delegate:consensus_pk.delegate\n ~participation\n ~attesting_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 per_block_vote =\n block_header.Block_header.protocol_data.contents.per_block_votes\n .liquidity_baking_vote\n in\n let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema =\n apply_liquidity_baking_subsidy ctxt ~per_block_vote\n in\n let* ctxt, adaptive_issuance_launch_cycle, adaptive_issuance_vote_ema =\n let adaptive_issuance_vote =\n block_header.Block_header.protocol_data.contents.per_block_votes\n .adaptive_issuance_vote\n in\n Adaptive_issuance.update_ema ctxt ~vote:adaptive_issuance_vote\n in\n let* ctxt =\n Sc_rollup.Inbox.add_level_info\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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\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 attestation/preattestation 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 per_block_vote =\n block_data_contents.per_block_votes.liquidity_baking_vote\n in\n let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema =\n apply_liquidity_baking_subsidy ctxt ~per_block_vote\n in\n let* ctxt, adaptive_issuance_launch_cycle, adaptive_issuance_vote_ema =\n let adaptive_issuance_vote =\n block_data_contents.per_block_votes.adaptive_issuance_vote\n in\n Adaptive_issuance.update_ema ctxt ~vote:adaptive_issuance_vote\n in\n let* ctxt =\n Sc_rollup.Inbox.add_level_info ~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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\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_hash\n ~(predecessor_fitness : Fitness.raw) : application_state tzresult Lwt.t =\n let open Lwt_result_syntax in\n let per_block_vote = Per_block_votes.Per_block_vote_pass in\n let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema =\n apply_liquidity_baking_subsidy ctxt ~per_block_vote\n in\n let* ctxt, adaptive_issuance_launch_cycle, adaptive_issuance_vote_ema =\n let adaptive_issuance_vote = Per_block_votes.Per_block_vote_pass in\n Adaptive_issuance.update_ema ctxt ~vote:adaptive_issuance_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 Sc_rollup.Inbox.add_level_info ~predecessor ctxt\n in\n let mode = Partial_construction {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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\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 ~adaptive_issuance_vote_ema\n ~adaptive_issuance_launch_cycle ~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 (* Compute consumed gas earlier, in case maintenance actions performed below\n are carbonated. *)\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 level = Level.current ctxt in\n let attestation_power = Consensus.current_attestation_power ctxt in\n let* required_attestations =\n are_attestations_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 attestation branch as the grand parent branch when\n accessible. This will not be present before the first two blocks\n of tenderbake. *)\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_attestation_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_attestations then\n let* ctxt = record_attesting_participation ctxt in\n let*? rewards_bonus =\n Baking.bonus_baking_reward ctxt ~attestation_power\n in\n return (ctxt, Some rewards_bonus)\n else return (ctxt, None)\n in\n let*? baking_reward = Delegate.Rewards.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, 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+ 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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\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 =\n Option.map fst (Consensus.locked_round_evidence ctxt)\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 ~adaptive_issuance_vote_ema\n ~adaptive_issuance_launch_cycle\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 (* Fake finalization to return a correct type, because there is no\n block to finalize in mempool mode. If this changes in the\n future, beware that consensus operations are not recorded by\n {!record_preattestation} and {!record_attestation} in this mode. *)\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 adaptive_issuance_vote_ema;\n adaptive_issuance_launch_cycle;\n implicit_operations_results;\n dal_attestation = Dal.Attestation.empty;\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 ~adaptive_issuance_vote_ema\n ~adaptive_issuance_launch_cycle\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\nmodule Internal_for_benchmark = struct\n let take_fees ctxt batch = ignore (take_fees ctxt batch)\nend\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 open Lwt_result_syntax in\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 let+ context, _, _ =\n Alpha_context.prepare\n ~level\n ~predecessor_timestamp:timestamp\n ~timestamp\n context\n in\n {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 let open Lwt_result_syntax in\n rpc_services :=\n RPC_directory.register ~chunked !rpc_services s (fun ctxt q i ->\n let* ctxt = rpc_init ctxt `Head_level in\n 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 let open Lwt_result_syntax in\n rpc_services :=\n RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i ->\n let* ctxt = rpc_init ctxt `Head_level in\n 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 let open Lwt_result_syntax in\n rpc_services :=\n RPC_directory.register\n ~chunked\n !rpc_services\n s\n (fun ((ctxt, arg1), arg2) q i ->\n let* ctxt = rpc_init ctxt `Head_level in\n 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 let open Lwt_result_syntax in\n rpc_services :=\n RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i ->\n let* ctxt = rpc_init ctxt `Head_level in\n 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 let open Lwt_result_syntax in\n rpc_services :=\n RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i ->\n let* ctxt = rpc_init ctxt `Head_level in\n 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 let open Lwt_result_syntax in\n rpc_services :=\n RPC_directory.opt_register\n ~chunked\n !rpc_services\n s\n (fun ((ctxt, arg1), arg2) q i ->\n let* ctxt = rpc_init ctxt `Head_level in\n 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 open Lwt_syntax in\n let p =\n RPC_directory.map\n (fun c ->\n let+ ctxt = rpc_init c `Head_level in\n match ctxt with\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 staked_balance :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n Tez.t option shell_tzresult Lwt.t\n\nval staking_numerator :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n Staking_pseudotoken.t shell_tzresult Lwt.t\n\nval unstaked_frozen_balance :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n Tez.t option shell_tzresult Lwt.t\n\nval unstaked_finalizable_balance :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n Tez.t option shell_tzresult Lwt.t\n\nval unstake_requests :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n Unstake_requests.prepared_finalize_unstake option shell_tzresult Lwt.t\n\nval full_balance :\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 estimated_own_pending_slashed_amount :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.public_key_hash ->\n Tez.t 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 staked_balance =\n RPC_service.get_service\n ~description:\n \"Access the staked balance of a contract. Returns None if the contract \\\n is originated, or neither delegated nor a delegate.\"\n ~query:RPC_query.empty\n ~output:(option Tez.encoding)\n RPC_path.(custom_root /: Contract.rpc_arg / \"staked_balance\")\n\n let staking_numerator =\n RPC_service.get_service\n ~description:\n \"Returns an abstract representation of the contract's \\\n total_delegated_stake.\"\n ~query:RPC_query.empty\n ~output:Staking_pseudotoken.For_RPC.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"staking_numerator\")\n\n let unstaked_frozen_balance =\n RPC_service.get_service\n ~description:\n \"Access the balance of a contract that was requested for an unstake \\\n operation, but is still frozen for the duration of the slashing \\\n period. Returns None if the contract is originated.\"\n ~query:RPC_query.empty\n ~output:(option Tez.encoding)\n RPC_path.(custom_root /: Contract.rpc_arg / \"unstaked_frozen_balance\")\n\n let unstaked_finalizable_balance =\n RPC_service.get_service\n ~description:\n \"Access the balance of a contract that was requested for an unstake \\\n operation, and is no longer frozen, which means it will appear in the \\\n spendable balance of the contract after any \\\n stake/unstake/finalize_unstake operation. Returns None if the \\\n contract is originated.\"\n ~query:RPC_query.empty\n ~output:(option Tez.encoding)\n RPC_path.(\n custom_root /: Contract.rpc_arg / \"unstaked_finalizable_balance\")\n\n let unstake_requests =\n RPC_service.get_service\n ~description:\n \"Access the unstake requests of the contract. The requests that appear \\\n in the finalizable field can be finalized, which means that the \\\n contract can transfer these (no longer frozen) funds to their \\\n spendable balance with a [finalize_unstake] operation call. Returns \\\n None if there is no unstake request pending.\"\n ~query:RPC_query.empty\n ~output:(option Unstake_requests.prepared_finalize_unstake_encoding)\n RPC_path.(custom_root /: Contract.rpc_arg / \"unstake_requests\")\n\n let full_balance =\n RPC_service.get_service\n ~description:\n \"Access the full balance of a contract, including frozen bonds and \\\n stake.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"full_balance\")\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 open Result_syntax in\n let int_of_string s =\n let* i =\n int_of_string_opt s\n |> Option.to_result\n ~none:(Format.sprintf \"Cannot parse integer value %s\" s)\n in\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 let estimated_own_pending_slashed_amount =\n RPC_service.get_service\n ~description:\n \"Returns the estimated own pending slashed amount (in mutez) of a \\\n given contract.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(\n custom_root /: Contract.rpc_arg / \"estimated_own_pending_slashed_amount\")\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 let open Lwt_result_syntax in\n let* ctxt, script = Contract.get_script ctxt contract_id in\n match script with\n | None -> return (None, ctxt)\n | Some script ->\n let ctxt = Gas.set_unlimited ctxt in\n let*! tzresult =\n Script_ir_translator.parse_script\n ctxt\n ~elab_conf:legacy\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n script\n in\n let*? Ex_script (Script script), ctxt = tzresult in\n Lwt.return\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 open Lwt_result_syntax in\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 let* sapling_id, ctxt = single_sapling_get_id ctxt contract_id in\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 Lwt_result_syntax in\n let open Services_registration in\n register0 ~chunked:true S.list (fun ctxt () () ->\n let*! result = Contract.list ctxt in\n return result) ;\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 let*! exists = Contract.exists ctxt contract in\n match exists with\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 let*! exists = Contract.exists ctxt contract in\n match exists with\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 ->\n let+ value = res in\n Option.some value)\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 ->\n let+ value = res in\n Option.some value)\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 let* ctxt, types = Big_map.exists ctxt id in\n match types with\n | None -> return_none\n | Some (_, value_type) -> (\n let*? Ex_ty value_type, ctxt =\n parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type)\n in\n let* _ctxt, value = Big_map.get_opt ctxt id key in\n match value with\n | None -> return_none\n | Some value ->\n let* value, ctxt =\n parse_data\n ctxt\n ~elab_conf:legacy\n ~allow_forged_tickets:true\n ~allow_forged_lazy_storage_id:true\n value_type\n (Micheline.root value)\n in\n let+ value, _ctxt = unparse_data ctxt Readable value_type value in\n 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 let* ctxt, types = Big_map.exists ctxt id in\n match types with\n | None -> raise Not_found\n | Some (_, value_type) ->\n let*? Ex_ty value_type, ctxt =\n parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type)\n in\n let* ctxt, key_values =\n Big_map.list_key_values ?offset ?length ctxt id\n in\n let+ _ctxt, rev_values =\n List.fold_left_s\n (fun acc (_key_hash, value) ->\n let*? ctxt, rev_values = acc in\n let* value, ctxt =\n parse_data\n ctxt\n ~elab_conf:legacy\n ~allow_forged_tickets:true\n ~allow_forged_lazy_storage_id:true\n value_type\n (Micheline.root value)\n in\n let+ value, ctxt = unparse_data ctxt Readable value_type value in\n (ctxt, value :: rev_values))\n (Ok (ctxt, []))\n key_values\n in\n 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 register_field\n ~chunked:false\n S.staked_balance\n Contract.For_RPC.get_staked_balance ;\n register_field ~chunked:false S.staking_numerator (fun ctxt delegator ->\n Staking_pseudotokens.For_RPC.staking_pseudotokens_balance ctxt ~delegator) ;\n register_field\n ~chunked:false\n S.unstaked_frozen_balance\n Contract.For_RPC.get_unstaked_frozen_balance ;\n register_field\n ~chunked:false\n S.unstaked_finalizable_balance\n Contract.For_RPC.get_unstaked_finalizable_balance ;\n register_field ~chunked:false S.full_balance Contract.For_RPC.get_full_balance ;\n register1 ~chunked:false S.unstake_requests (fun ctxt contract () () ->\n let* result = Unstake_requests.prepare_finalize_unstake ctxt contract in\n match result with\n | None -> return_none\n | Some {finalizable; unfinalizable} ->\n let* unfinalizable =\n Unstake_requests.For_RPC\n .apply_slash_to_unstaked_unfinalizable_stored_requests\n ctxt\n unfinalizable\n in\n return_some Unstake_requests.{finalizable; unfinalizable}) ;\n opt_register1 ~chunked:false S.manager_key (fun ctxt contract () () ->\n match contract with\n | Originated _ -> return_none\n | Implicit mgr -> (\n let* is_revealed = Contract.is_manager_key_revealed ctxt mgr in\n match is_revealed with\n | false -> return_some None\n | true ->\n let+ key = Contract.get_manager_key ctxt mgr in\n 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 let+ counter = Contract.get_counter ctxt mgr in\n Some counter) ;\n register_originated_opt_field ~chunked:true S.script (fun c v ->\n let+ _, v = Contract.get_script c v in\n v) ;\n register_originated_opt_field ~chunked:true S.storage (fun ctxt contract ->\n let* ctxt, script = Contract.get_script ctxt contract in\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 let* Ex_script (Script {storage; storage_type; _}), ctxt =\n parse_script\n ctxt\n ~elab_conf:legacy\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n script\n in\n let+ storage, _ctxt =\n unparse_data ctxt Readable storage_type storage\n in\n 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 let* _, expr = Contract.get_script_code ctxt v in\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 let*? expr, _ =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n expr\n in\n let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in\n let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ =\n parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type\n in\n let*? r, ctxt =\n Gas_monad.run ctxt\n @@ Script_ir_translator.find_entrypoint\n ~error_details:(Informative ())\n arg_type\n entrypoints\n entrypoint\n in\n r |> function\n | Ok (Ex_ty_cstr {ty; original_type_expr; _}) ->\n if normalize_types then\n let*? ty_node, _ctxt =\n Script_ir_unparser.unparse_ty ~loc:() ctxt ty\n in\n return_some (Micheline.strip_locations ty_node)\n else\n return_some (Micheline.strip_locations original_type_expr)\n | Error _ -> 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 let* _, expr = Contract.get_script_code ctxt v in\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 let*? expr, _ =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n expr\n in\n let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in\n Lwt.return\n (let open Result_syntax in\n let* Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _\n =\n parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type\n in\n let unreachable_entrypoint, map =\n Script_ir_translator.list_entrypoints_uncarbonated\n arg_type\n entrypoints\n in\n let* entrypoint_types, _ctxt =\n Entrypoint.Map.fold_e\n (fun entry\n (Script_typed_ir.Ex_ty ty, original_type_expr)\n (acc, ctxt) ->\n let* ty_expr, ctxt =\n if normalize_types then\n let* ty_node, ctxt =\n Script_ir_unparser.unparse_ty ~loc:() ctxt ty\n in\n return (Micheline.strip_locations ty_node, ctxt)\n else\n return\n (Micheline.strip_locations original_type_expr, ctxt)\n in\n return ((Entrypoint.to_string entry, ty_expr) :: acc, ctxt))\n map\n ([], ctxt)\n in\n return_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 let* ctxt, script = Contract.get_script ctxt contract in\n let key_type_node = Micheline.root key_type in\n let*? Ex_comparable_ty key_type, ctxt =\n Script_ir_translator.parse_comparable_ty ctxt key_type_node\n in\n let* key, ctxt =\n Script_ir_translator.parse_comparable_data\n ctxt\n key_type\n (Micheline.root key)\n in\n let* key, ctxt =\n Script_ir_translator.hash_comparable_data ctxt key_type key\n in\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 let* Ex_script (Script script), ctxt =\n parse_script\n ctxt\n ~elab_conf:legacy\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n script\n in\n let*? ids, _ctxt =\n Script_ir_translator.collect_lazy_storage\n ctxt\n script.storage_type\n script.storage\n in\n match Script_ir_translator.list_of_big_map_ids ids with\n | [] | _ :: _ :: _ -> return_some None\n | [id] ->\n let+ result = do_big_map_get ctxt id key in\n Option.some result))) ;\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 let* balance = Contract.get_balance ctxt contract in\n let* delegate = Contract.Delegate.find ctxt contract in\n match contract with\n | Implicit manager ->\n let+ counter = Contract.get_counter ctxt manager in\n {balance; delegate; script = None; counter = Some counter}\n | Originated contract -> (\n let* ctxt, script = Contract.get_script ctxt contract in\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 let+ script, _ctxt =\n Script_ir_translator.parse_and_unparse_script_unaccounted\n ctxt\n ~legacy:true\n ~allow_forged_tickets_in_storage:true\n ~allow_forged_lazy_storage_id_in_storage:true\n Readable\n ~normalize_types\n script\n in\n {balance; delegate; script = Some script; counter = None})) ;\n register1\n ~chunked:false\n S.estimated_own_pending_slashed_amount\n (fun ctxt contract () () ->\n Contract.For_RPC.get_estimated_own_pending_slashed_amount ctxt contract) ;\n\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 staked_balance ctxt block contract =\n RPC_context.make_call1 S.staked_balance ctxt block contract () ()\n\nlet staking_numerator ctxt block contract =\n RPC_context.make_call1 S.staking_numerator ctxt block contract () ()\n\nlet unstaked_frozen_balance ctxt block contract =\n RPC_context.make_call1 S.unstaked_frozen_balance ctxt block contract () ()\n\nlet unstaked_finalizable_balance ctxt block contract =\n RPC_context.make_call1\n S.unstaked_finalizable_balance\n ctxt\n block\n contract\n ()\n ()\n\nlet unstake_requests ctxt block contract =\n RPC_context.make_call1 S.unstake_requests ctxt block contract () ()\n\nlet full_balance ctxt block contract =\n RPC_context.make_call1 S.full_balance 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 estimated_own_pending_slashed_amount ctxt block contract =\n let contract = Contract.Implicit contract in\n RPC_context.make_call1\n S.estimated_own_pending_slashed_amount\n ctxt\n block\n contract\n ()\n ()\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 consensus_key = {\n consensus_key_pkh : Signature.Public_key_hash.t;\n consensus_key_pk : Signature.Public_key.t;\n}\n\ntype consensus_keys_info = {\n active : consensus_key;\n pendings : (Cycle.t * consensus_key) list;\n}\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 min_delegated_in_current_cycle : Tez.t * Level_repr.t option;\n total_delegated_stake : Tez.t;\n staking_denominator : Staking_pseudotoken.t;\n deactivated : bool;\n grace_period : Cycle.t;\n pending_denunciations : bool;\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\ntype deposit_per_cycle = {cycle : Cycle.t; deposit : Tez.t}\n\nval deposit_per_cycle_encoding : deposit_per_cycle Data_encoding.t\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 unstaked_frozen_deposits :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n deposit_per_cycle list 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 total_delegated_stake :\n 'a #RPC_context.simple -> 'a -> public_key_hash -> Tez.t shell_tzresult Lwt.t\n\nval staking_denominator :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Staking_pseudotoken.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 current_voting_power :\n 'a #RPC_context.simple -> 'a -> public_key_hash -> int64 shell_tzresult Lwt.t\n\nval voting_power :\n 'a #RPC_context.simple -> 'a -> public_key_hash -> int64 shell_tzresult Lwt.t\n\nval current_baking_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 consensus_keys_info shell_tzresult Lwt.t\n\nval participation :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Delegate.For_RPC.participation_info shell_tzresult Lwt.t\n\nval active_staking_parameters :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Staking_parameters_repr.t shell_tzresult Lwt.t\n\nval pending_staking_parameters :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n (Cycle.t * Staking_parameters_repr.t) list shell_tzresult Lwt.t\n\nval pending_denunciations :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Denunciations_repr.t shell_tzresult Lwt.t\n\nval estimated_shared_pending_slashed_amount :\n 'a #RPC_context.simple -> 'a -> public_key_hash -> Tez.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(* 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 consensus_key = {\n consensus_key_pkh : Signature.Public_key_hash.t;\n consensus_key_pk : Signature.Public_key.t;\n}\n\nlet consensus_key_encoding =\n let open Data_encoding in\n conv\n (fun {consensus_key_pkh; consensus_key_pk} ->\n (consensus_key_pkh, consensus_key_pk))\n (fun (consensus_key_pkh, consensus_key_pk) ->\n {consensus_key_pkh; consensus_key_pk})\n (obj2\n (req \"pkh\" Signature.Public_key_hash.encoding)\n (req \"pk\" Signature.Public_key.encoding))\n\ntype consensus_keys_info = {\n active : consensus_key;\n pendings : (Cycle.t * consensus_key) list;\n}\n\nlet consensus_key_info_encoding =\n let open Data_encoding in\n conv\n (fun {active; pendings} -> (active, pendings))\n (fun (active, pendings) -> {active; pendings})\n (obj2\n (req \"active\" consensus_key_encoding)\n (dft\n \"pendings\"\n (list\n (merge_objs\n (obj1 (req \"cycle\" Cycle.encoding))\n consensus_key_encoding))\n []))\n\nlet min_delegated_in_current_cycle_encoding =\n let open Data_encoding in\n conv\n (fun (min_delegated, anchor) -> (min_delegated, anchor))\n (fun (min_delegated, anchor) -> (min_delegated, anchor))\n (obj2 (req \"amount\" Tez.encoding) (opt \"level\" Level_repr.encoding))\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 min_delegated_in_current_cycle : Tez.t * Level_repr.t option;\n total_delegated_stake : Tez.t;\n staking_denominator : Staking_pseudotoken.t;\n deactivated : bool;\n grace_period : Cycle.t;\n pending_denunciations : bool;\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 min_delegated_in_current_cycle;\n total_delegated_stake;\n staking_denominator;\n deactivated;\n grace_period;\n pending_denunciations;\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 min_delegated_in_current_cycle,\n deactivated,\n grace_period ),\n ( (pending_denunciations, total_delegated_stake, staking_denominator),\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 min_delegated_in_current_cycle,\n deactivated,\n grace_period ),\n ( (pending_denunciations, total_delegated_stake, staking_denominator),\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 min_delegated_in_current_cycle;\n total_delegated_stake;\n staking_denominator;\n deactivated;\n grace_period;\n pending_denunciations;\n voting_info;\n active_consensus_key;\n pending_consensus_keys;\n })\n (merge_objs\n (obj10\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\n \"min_delegated_in_current_cycle\"\n min_delegated_in_current_cycle_encoding)\n (req \"deactivated\" bool)\n (req \"grace_period\" Cycle.encoding))\n (merge_objs\n (obj3\n (req \"pending_denunciations\" bool)\n (req \"total_delegated_stake\" Tez.encoding)\n (req \"staking_denominator\" Staking_pseudotoken.For_RPC.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 Delegate.For_RPC.\n {\n expected_cycle_activity;\n minimal_cycle_activity;\n missed_slots;\n missed_levels;\n remaining_allowed_missed_slots;\n expected_attesting_rewards;\n } ->\n ( expected_cycle_activity,\n minimal_cycle_activity,\n missed_slots,\n missed_levels,\n remaining_allowed_missed_slots,\n expected_attesting_rewards ))\n (fun ( expected_cycle_activity,\n minimal_cycle_activity,\n missed_slots,\n missed_levels,\n remaining_allowed_missed_slots,\n expected_attesting_rewards ) ->\n {\n expected_cycle_activity;\n minimal_cycle_activity;\n missed_slots;\n missed_levels;\n remaining_allowed_missed_slots;\n expected_attesting_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_attesting_rewards\" Tez.encoding))\n\ntype deposit_per_cycle = {cycle : Cycle.t; deposit : Tez.t}\n\nlet deposit_per_cycle_encoding : deposit_per_cycle Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {cycle; deposit} -> (cycle, deposit))\n (fun (cycle, deposit) -> {cycle; deposit})\n (obj2 (req \"cycle\" Cycle.encoding) (req \"deposit\" Tez.encoding))\n\ntype pending_staking_parameters = Cycle.t * Staking_parameters_repr.t\n\nlet pending_staking_parameters_encoding :\n pending_staking_parameters Data_encoding.t =\n let open Data_encoding in\n obj2\n (req \"cycle\" Cycle.encoding)\n (req \"parameters\" Staking_parameters_repr.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). That is \\\n the frozen deposits at beginning of cycle plus rewards minus unstaked \\\n and slashing. It doesn't count unstaked frozen deposits.\"\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 amount (in mutez) frozen as a deposit at the time the \\\n staking rights for the current cycle where computed.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"frozen_deposits\")\n\n let unstaked_frozen_deposits =\n RPC_service.get_service\n ~description:\n \"Returns, for each cycle, the sum of unstaked-but-frozen deposits for \\\n this cycle. Cycles go from the last unslashable cycle to the current \\\n cycle.\"\n ~query:RPC_query.empty\n ~output:(Data_encoding.list deposit_per_cycle_encoding)\n RPC_path.(path / \"unstaked_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 total_delegated_stake =\n RPC_service.get_service\n ~description:\n \"Returns the sum (in mutez) of all tokens staked by the delegators of \\\n a given delegate. This excludes the delegate's own staked tokens.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"total_delegated_stake\")\n\n let staking_denominator =\n RPC_service.get_service\n ~description:\n \"Returns an abstract representation of the total delegated stake.\"\n ~query:RPC_query.empty\n ~output:Staking_pseudotoken.For_RPC.encoding\n RPC_path.(path / \"staking_denominator\")\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 min_delegated_in_current_cycle =\n RPC_service.get_service\n ~description:\n \"Returns the minimum of delegated tez (in mutez) over the current \\\n cycle and the block level where this value was last updated (* Level \\\n is `None` when decoding values from protocol O).\"\n ~query:RPC_query.empty\n ~output:min_delegated_in_current_cycle_encoding\n RPC_path.(path / \"min_delegated_in_current_cycle\")\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 current_voting_power =\n RPC_service.get_service\n ~description:\n \"The voting power of a given delegate, as computed from its current \\\n stake.\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int64\n RPC_path.(path / \"current_voting_power\")\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 current_baking_power =\n RPC_service.get_service\n ~description:\n \"The baking power of a delegate, as computed from its current stake. \\\n This value is not used for computing baking rights but only reflects \\\n the baking power that the delegate would have if the cycle ended at \\\n the current block.\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int64\n RPC_path.(path / \"current_baking_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:consensus_key_info_encoding\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 attesting slots in the cycle required to get attesting \\\n rewards. It is computed based on 'expected_cycle_activity. The fields \\\n 'missed_slots' and 'missed_levels' indicate the number of missed \\\n attesting slots and missed levels (for attesting) in the cycle so \\\n far. 'missed_slots' indicates the number of missed attesting slots in \\\n the cycle so far. The field 'remaining_allowed_missed_slots' \\\n indicates the remaining amount of attesting slots that can be missed \\\n in the cycle before forfeiting the rewards. Finally, \\\n 'expected_attesting_rewards' indicates the attesting 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\")\n\n let active_staking_parameters =\n RPC_service.get_service\n ~description:\n \"Returns the currently active staking parameters for the given \\\n delegate.\"\n ~query:RPC_query.empty\n ~output:Staking_parameters_repr.encoding\n RPC_path.(path / \"active_staking_parameters\")\n\n let pending_staking_parameters =\n RPC_service.get_service\n ~description:\n \"Returns the pending values for the given delegate's staking \\\n parameters.\"\n ~query:RPC_query.empty\n ~output:(list pending_staking_parameters_encoding)\n RPC_path.(path / \"pending_staking_parameters\")\n\n let pending_denunciations =\n RPC_service.get_service\n ~description:\"Returns the pending denunciations for the given delegate.\"\n ~query:RPC_query.empty\n ~output:(list Denunciations_repr.item_encoding)\n RPC_path.(path / \"denunciations\")\n\n let estimated_shared_pending_slashed_amount =\n RPC_service.get_service\n ~description:\n \"Returns the estimated shared pending slashed amount (in mutez) of a \\\n given delegate.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"estimated_shared_pending_slashed_amount\")\nend\n\nlet check_delegate_registered ctxt pkh =\n let open Lwt_result_syntax in\n let*! is_registered = Delegate.registered ctxt pkh in\n match is_registered with\n | true -> return_unit\n | false -> tzfail (Not_registered pkh)\n\nlet register () =\n let open Services_registration in\n let open Lwt_result_syntax in\n register0 ~chunked:true S.list_delegate (fun ctxt q () ->\n let*! delegates = Delegate.list ctxt in\n let* delegates =\n match q with\n | {active = true; inactive = false; _} ->\n List.filter_es\n (fun pkh ->\n let+ deactivated = Delegate.deactivated ctxt pkh in\n not deactivated)\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 in\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 let+ staking_balance =\n Delegate.For_RPC.staking_balance ctxt pkh\n in\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 let+ staking_balance =\n Delegate.For_RPC.staking_balance ctxt pkh\n in\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 let* () = check_delegate_registered ctxt pkh in\n let* full_balance = Delegate.For_RPC.full_balance ctxt pkh in\n let* current_frozen_deposits =\n Delegate.current_frozen_deposits ctxt pkh\n in\n let* frozen_deposits = Delegate.initial_frozen_deposits ctxt pkh in\n let* staking_balance = Delegate.For_RPC.staking_balance ctxt pkh in\n let* frozen_deposits_limit = Delegate.frozen_deposits_limit ctxt pkh in\n let*! delegated_contracts = Delegate.delegated_contracts ctxt pkh in\n let* delegated_balance = Delegate.For_RPC.delegated_balance ctxt pkh in\n let* min_delegated_in_current_cycle =\n Delegate.For_RPC.min_delegated_in_current_cycle ctxt pkh\n in\n let* total_delegated_stake =\n Staking_pseudotokens.For_RPC.get_frozen_deposits_staked_tez\n ctxt\n ~delegate:pkh\n in\n let* staking_denominator =\n Staking_pseudotokens.For_RPC.get_frozen_deposits_pseudotokens\n ctxt\n ~delegate:pkh\n in\n let* deactivated = Delegate.deactivated ctxt pkh in\n let* grace_period = Delegate.last_cycle_before_deactivation ctxt pkh in\n let*! pending_denunciations =\n Delegate.For_RPC.has_pending_denunciations ctxt pkh\n in\n let* voting_info = Vote.get_delegate_info ctxt pkh in\n let* consensus_key = Delegate.Consensus_key.active_pubkey ctxt pkh in\n let+ pendings = Delegate.Consensus_key.pending_updates ctxt pkh in\n let pending_consensus_keys =\n List.map (fun (cycle, pkh, _) -> (cycle, pkh)) pendings\n in\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 min_delegated_in_current_cycle;\n total_delegated_stake;\n staking_denominator;\n deactivated;\n grace_period;\n pending_denunciations;\n voting_info;\n active_consensus_key = consensus_key.consensus_pkh;\n pending_consensus_keys;\n }) ;\n register1 ~chunked:false S.full_balance (fun ctxt pkh () () ->\n let* () =\n trace\n (Balance_rpc_non_delegate pkh)\n (check_delegate_registered ctxt pkh)\n in\n Delegate.For_RPC.full_balance ctxt pkh) ;\n register1 ~chunked:false S.current_frozen_deposits (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.current_frozen_deposits ctxt pkh) ;\n register1 ~chunked:false S.frozen_deposits (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.initial_frozen_deposits ctxt pkh) ;\n register1 ~chunked:false S.unstaked_frozen_deposits (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n let ctxt_cycle = (Alpha_context.Level.current ctxt).cycle in\n let last_unslashable_cycle =\n Option.value ~default:Cycle.root\n @@ Cycle.sub\n ctxt_cycle\n (Constants.slashable_deposits_period ctxt\n + Constants_repr.max_slashing_period)\n in\n let cycles = Cycle.(last_unslashable_cycle ---> ctxt_cycle) in\n let* requests =\n List.map_es\n (fun cycle ->\n let* deposit = Unstaked_frozen_deposits.balance ctxt pkh cycle in\n return (cycle, deposit))\n cycles\n in\n let* slashed_requests =\n Alpha_context.Unstake_requests.For_RPC\n .apply_slash_to_unstaked_unfinalizable\n ctxt\n ~delegate:pkh\n ~requests\n in\n List.map_es\n (fun (cycle, deposit) -> return {cycle; deposit})\n slashed_requests) ;\n register1 ~chunked:false S.staking_balance (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.For_RPC.staking_balance ctxt pkh) ;\n register1 ~chunked:false S.frozen_deposits_limit (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.frozen_deposits_limit ctxt pkh) ;\n register1 ~chunked:true S.delegated_contracts (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n let*! contracts = Delegate.delegated_contracts ctxt pkh in\n return contracts) ;\n register1 ~chunked:false S.delegated_balance (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.For_RPC.delegated_balance ctxt pkh) ;\n register1\n ~chunked:false\n S.min_delegated_in_current_cycle\n (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.For_RPC.min_delegated_in_current_cycle ctxt pkh) ;\n register1 ~chunked:false S.total_delegated_stake (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Staking_pseudotokens.For_RPC.get_frozen_deposits_staked_tez\n ctxt\n ~delegate:pkh) ;\n register1 ~chunked:false S.staking_denominator (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Staking_pseudotokens.For_RPC.get_frozen_deposits_pseudotokens\n ctxt\n ~delegate:pkh) ;\n register1 ~chunked:false S.deactivated (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.deactivated ctxt pkh) ;\n register1 ~chunked:false S.grace_period (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.last_cycle_before_deactivation ctxt pkh) ;\n register1 ~chunked:false S.current_voting_power (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Vote.get_current_voting_power_free ctxt pkh) ;\n register1 ~chunked:false S.voting_power (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Vote.get_voting_power_free ctxt pkh) ;\n register1 ~chunked:false S.current_baking_power (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Stake_distribution.For_RPC.delegate_current_baking_power ctxt pkh) ;\n register1 ~chunked:false S.voting_info (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Vote.get_delegate_info ctxt pkh) ;\n register1 ~chunked:false S.consensus_key (fun ctxt pkh () () ->\n let* {\n consensus_pk = consensus_key_pk;\n consensus_pkh = consensus_key_pkh;\n _;\n } =\n Delegate.Consensus_key.active_pubkey ctxt pkh\n in\n let* pendings = Delegate.Consensus_key.pending_updates ctxt pkh in\n let pendings =\n List.map\n (fun (cycle, consensus_key_pkh, consensus_key_pk) ->\n (cycle, {consensus_key_pk; consensus_key_pkh}))\n pendings\n in\n return {active = {consensus_key_pk; consensus_key_pkh}; pendings}) ;\n register1 ~chunked:false S.participation (fun ctxt pkh () () ->\n let* () = check_delegate_registered ctxt pkh in\n Delegate.For_RPC.participation_info ctxt pkh) ;\n register1 ~chunked:false S.active_staking_parameters (fun ctxt pkh () () ->\n Delegate.Staking_parameters.of_delegate ctxt pkh) ;\n register1 ~chunked:false S.pending_staking_parameters (fun ctxt pkh () () ->\n Delegate.Staking_parameters.pending_updates ctxt pkh) ;\n register1 ~chunked:false S.pending_denunciations (fun ctxt pkh () () ->\n Delegate.For_RPC.pending_denunciations ctxt pkh) ;\n register1\n ~chunked:false\n S.estimated_shared_pending_slashed_amount\n (fun ctxt delegate () () ->\n let* () = check_delegate_registered ctxt delegate in\n Delegate.For_RPC.get_estimated_shared_pending_slashed_amount ctxt delegate)\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 unstaked_frozen_deposits ctxt block pkh =\n RPC_context.make_call1 S.unstaked_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 total_delegated_stake ctxt block pkh =\n RPC_context.make_call1 S.total_delegated_stake ctxt block pkh () ()\n\nlet staking_denominator ctxt block pkh =\n RPC_context.make_call1 S.staking_denominator 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 current_voting_power ctxt block pkh =\n RPC_context.make_call1 S.current_voting_power ctxt block pkh () ()\n\nlet current_baking_power ctxt block pkh =\n RPC_context.make_call1 S.current_baking_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\nlet active_staking_parameters ctxt block pkh =\n RPC_context.make_call1 S.active_staking_parameters ctxt block pkh () ()\n\nlet pending_staking_parameters ctxt block pkh =\n RPC_context.make_call1 S.pending_staking_parameters ctxt block pkh () ()\n\nlet pending_denunciations ctxt block pkh =\n RPC_context.make_call1 S.pending_denunciations ctxt block pkh () ()\n\nlet estimated_shared_pending_slashed_amount ctxt block pkh =\n RPC_context.make_call1\n S.estimated_shared_pending_slashed_amount\n ctxt\n block\n pkh\n ()\n ()\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\nval delegate_proposal_count :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n int 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\")\n\n let delegate_proposal_count =\n RPC_service.get_service\n ~description:\"Number of votes casted during the current period.\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int31\n RPC_path.(path / \"proposal_count\" /: Signature.Public_key_hash.rpc_arg)\nend\n\nlet register () =\n let open Lwt_syntax in\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 let+ result = Vote.get_ballot_list ctxt in\n Ok result) ;\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 let+ result = Vote.get_listings ctxt in\n Ok result) ;\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 register1 ~chunked:false S.delegate_proposal_count (fun ctxt pkh () () ->\n Vote.get_delegate_proposal_count ctxt pkh)\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\nlet delegate_proposal_count ctxt block pkh =\n RPC_context.make_call1 S.delegate_proposal_count ctxt block pkh () ()\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 a mapping from the public\n key hash of members of the committee to the list of shard indexes associated\n to that member. *)\nval shards :\n Alpha_context.t ->\n level:Alpha_context.Level.t ->\n (Alpha_context.t * int list Signature.Public_key_hash.Map.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 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\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 shards ctxt ~level =\n let open Lwt_result_syntax in\n let*? () = assert_dal_feature_enabled ctxt in\n let number_of_shards = Dal.number_of_shards ctxt in\n let*? slots = Slot.Range.create ~min:0 ~count:number_of_shards in\n Slot.Range.rev_fold_es\n (fun (ctxt, map) slot ->\n let* ctxt, consensus_pk = Stake_distribution.slot_owner ctxt level slot in\n let slot = Slot.to_int slot in\n let map =\n Signature.Public_key_hash.Map.update\n consensus_pk.delegate\n (function None -> Some [slot] | Some slots -> Some (slot :: slots))\n map\n in\n return (ctxt, map))\n (ctxt, Signature.Public_key_hash.Map.empty)\n slots\n" ;
} ;
{ name = "Adaptive_issuance_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 expected_rewards = {\n cycle : Cycle.t;\n baking_reward_fixed_portion : Tez.t;\n baking_reward_bonus_per_slot : Tez.t;\n attesting_reward_per_slot : Tez.t;\n seed_nonce_revelation_tip : Tez.t;\n vdf_revelation_tip : Tez.t;\n}\n\nval expected_rewards_encoding : expected_rewards Data_encoding.t\n\nval total_supply : 'a #RPC_context.simple -> 'a -> Tez.t shell_tzresult Lwt.t\n\nval total_frozen_stake :\n 'a #RPC_context.simple -> 'a -> Tez.t shell_tzresult Lwt.t\n\nval current_yearly_rate :\n 'a #RPC_context.simple -> 'a -> string shell_tzresult Lwt.t\n\nval current_yearly_rate_exact :\n 'a #RPC_context.simple -> 'a -> Q.t shell_tzresult Lwt.t\n\nval current_yearly_rate_details :\n 'a #RPC_context.simple -> 'a -> (Q.t * Q.t) shell_tzresult Lwt.t\n\nval current_issuance_per_minute :\n 'a #RPC_context.simple -> 'a -> Tez.t shell_tzresult Lwt.t\n\nval launch_cycle :\n 'a #RPC_context.simple -> 'a -> Cycle.t option shell_tzresult Lwt.t\n\n(** Returns the list of expected issued tez for the current cycle and for the next\n [consensus_rights_delay] cycles. *)\nval expected_issuance :\n 'a #RPC_context.simple -> 'a -> expected_rewards list shell_tzresult Lwt.t\n\nval register : unit -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2023 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 expected_rewards = {\n cycle : Cycle.t;\n baking_reward_fixed_portion : Tez.t;\n baking_reward_bonus_per_slot : Tez.t;\n attesting_reward_per_slot : Tez.t;\n seed_nonce_revelation_tip : Tez.t;\n vdf_revelation_tip : Tez.t;\n}\n\nlet expected_rewards_encoding : expected_rewards Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {\n cycle;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n attesting_reward_per_slot;\n seed_nonce_revelation_tip;\n vdf_revelation_tip;\n } ->\n ( cycle,\n baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n attesting_reward_per_slot,\n seed_nonce_revelation_tip,\n vdf_revelation_tip ))\n (fun ( cycle,\n baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n attesting_reward_per_slot,\n seed_nonce_revelation_tip,\n vdf_revelation_tip ) ->\n {\n cycle;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n attesting_reward_per_slot;\n seed_nonce_revelation_tip;\n vdf_revelation_tip;\n })\n (obj6\n (req \"cycle\" Cycle.encoding)\n (req \"baking_reward_fixed_portion\" Tez.encoding)\n (req \"baking_reward_bonus_per_slot\" Tez.encoding)\n (req \"attesting_reward_per_slot\" Tez.encoding)\n (req \"seed_nonce_revelation_tip\" Tez.encoding)\n (req \"vdf_revelation_tip\" Tez.encoding))\n\nmodule S = struct\n open Data_encoding\n\n let q_encoding =\n conv\n (fun Q.{num; den} -> (num, den))\n (fun (num, den) -> Q.make num den)\n (obj2 (req \"numerator\" n) (req \"denominator\" n))\n\n let context_path = RPC_path.(open_root / \"context\")\n\n let path = RPC_path.(context_path / \"issuance\")\n\n let total_supply =\n RPC_service.get_service\n ~description:\"Returns the total supply (in mutez) available on the chain\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(context_path / \"total_supply\")\n\n let total_frozen_stake =\n RPC_service.get_service\n ~description:\"Returns the total stake (in mutez) frozen on the chain\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(context_path / \"total_frozen_stake\")\n\n let current_yearly_rate =\n RPC_service.get_service\n ~description:\n \"Returns the current expected maximum yearly issuance rate (in %)\"\n ~query:RPC_query.empty\n ~output:(string Plain)\n RPC_path.(path / \"current_yearly_rate\")\n\n let current_yearly_rate_exact =\n RPC_service.get_service\n ~description:\n \"Returns the current expected maximum yearly issuance rate (exact \\\n quotient)\"\n ~query:RPC_query.empty\n ~output:q_encoding\n RPC_path.(path / \"current_yearly_rate_exact\")\n\n let current_yearly_rate_details =\n RPC_service.get_service\n ~description:\n \"Returns the static and dynamic parts of the current expected maximum \\\n yearly issuance rate.\"\n ~query:RPC_query.empty\n ~output:(obj2 (req \"static\" q_encoding) (req \"dynamic\" q_encoding))\n RPC_path.(path / \"current_yearly_rate_details\")\n\n let current_issuance_per_minute =\n RPC_service.get_service\n ~description:\n \"Returns the current expected maximum issuance per minute (in mutez)\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"issuance_per_minute\")\n\n let launch_cycle =\n RPC_service.get_service\n ~description:\n \"Returns the cycle at which the launch of the Adaptive Issuance \\\n feature is set to happen. A result of None means that the feature is \\\n not yet set to launch.\"\n ~query:RPC_query.empty\n ~output:(Data_encoding.option Cycle.encoding)\n RPC_path.(context_path / \"adaptive_issuance_launch_cycle\")\n\n let expected_issuance =\n RPC_service.get_service\n ~description:\n \"Returns the expected issued tez for the provided block and the next \\\n 'consensus_rights_delay' cycles\"\n ~query:RPC_query.empty\n ~output:(Data_encoding.list expected_rewards_encoding)\n RPC_path.(path / \"expected_issuance\")\nend\n\nlet q_to_float_string q =\n let offset = 1000 in\n let unit = Z.div q.Q.num q.den in\n let q = Q.(sub q (unit /// Z.one)) in\n let q = Q.(mul q (offset // 1)) in\n let dec = Z.div q.num q.den in\n let padded_dec_string = Format.asprintf \"%03d\" (Z.to_int dec) in\n Format.asprintf \"%a.%s\" Z.pp_print unit padded_dec_string\n\nlet current_rewards_per_minute ctxt =\n let open Lwt_result_syntax in\n let base_total_issued_per_minute =\n (Constants.issuance_weights ctxt).base_total_issued_per_minute\n in\n let q_base_total_issued_per_minute =\n Tez.to_mutez base_total_issued_per_minute |> Q.of_int64\n in\n let cycle = (Level.current ctxt).cycle in\n let* f = Delegate.Rewards.For_RPC.get_reward_coeff ctxt ~cycle in\n let f = Q.mul f q_base_total_issued_per_minute (* rewards per minute *) in\n return f\n\n(* Does the reverse operations of [compute_coeff] in [adaptive_issuance_storage.ml] *)\nlet current_yearly_rate_value ~formatter ctxt =\n let open Lwt_result_syntax in\n let q_min_per_year = Q.of_int 525600 in\n let* total_supply = Contract.get_total_supply ctxt in\n let q_total_supply = Tez.to_mutez total_supply |> Q.of_int64 in\n let* f = current_rewards_per_minute ctxt in\n let f = Q.div f q_total_supply (* issuance rate per minute *) in\n let f = Q.mul f q_min_per_year (* issuance rate per year *) in\n (* transform into a string *)\n let f = Q.(mul f (100 // 1)) in\n return (formatter f)\n\nlet collect_expected_rewards ~ctxt =\n let open Lwt_result_syntax in\n let open Delegate.Rewards in\n let ctxt_cycle = (Level.current ctxt).cycle in\n let csts = (Constants.all ctxt).parametric in\n let reward_of_cycle cycle =\n if Cycle.(cycle = ctxt_cycle) then\n let*? baking_reward_fixed_portion = baking_reward_fixed_portion ctxt in\n let*? baking_reward_bonus_per_slot = baking_reward_bonus_per_slot ctxt in\n let*? attesting_reward_per_slot = attesting_reward_per_slot ctxt in\n let*? seed_nonce_revelation_tip = seed_nonce_revelation_tip ctxt in\n let*? vdf_revelation_tip = vdf_revelation_tip ctxt in\n return\n {\n cycle;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n attesting_reward_per_slot;\n seed_nonce_revelation_tip;\n vdf_revelation_tip;\n }\n else\n (* This coeff is correct only when applied to Cycle lesser than\n [issuance_modification_delay] after the current context, otherwise the coeff will\n not be set and thus we get the default values. *)\n let open Delegate.Rewards.For_RPC in\n let* coeff = get_reward_coeff ctxt ~cycle in\n\n let*? baking_reward_fixed_portion =\n reward_from_constants\n ~coeff\n csts\n ~reward_kind:Baking_reward_fixed_portion\n in\n let*? baking_reward_bonus_per_slot =\n reward_from_constants\n ~coeff\n csts\n ~reward_kind:Baking_reward_bonus_per_slot\n in\n let*? attesting_reward_per_slot =\n reward_from_constants ~coeff csts ~reward_kind:Attesting_reward_per_slot\n in\n let*? seed_nonce_revelation_tip =\n reward_from_constants ~coeff csts ~reward_kind:Seed_nonce_revelation_tip\n in\n let*? vdf_revelation_tip =\n reward_from_constants ~coeff csts ~reward_kind:Vdf_revelation_tip\n in\n return\n {\n cycle;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n attesting_reward_per_slot;\n seed_nonce_revelation_tip;\n vdf_revelation_tip;\n }\n in\n let queried_cycles =\n Cycle.(\n ctxt_cycle\n ---> add ctxt_cycle (Constants.issuance_modification_delay ctxt))\n in\n List.map_es reward_of_cycle queried_cycles\n\nlet register () =\n let open Services_registration in\n let open Lwt_result_syntax in\n register0 ~chunked:false S.total_supply (fun ctxt () () ->\n Contract.get_total_supply ctxt) ;\n register0 ~chunked:false S.total_frozen_stake (fun ctxt () () ->\n let cycle = (Level.current ctxt).cycle in\n Stake_distribution.get_total_frozen_stake ctxt cycle) ;\n register0 ~chunked:false S.current_yearly_rate (fun ctxt () () ->\n current_yearly_rate_value ~formatter:q_to_float_string ctxt) ;\n register0 ~chunked:false S.current_yearly_rate_exact (fun ctxt () () ->\n current_yearly_rate_value ~formatter:(fun x -> x) ctxt) ;\n register0 ~chunked:false S.current_yearly_rate_details (fun ctxt () () ->\n let* total = current_yearly_rate_value ~formatter:(fun x -> x) ctxt in\n let cycle = Some (Level.current ctxt).cycle in\n let* bonus = Delegate.Rewards.For_RPC.get_reward_bonus ctxt ~cycle in\n let dynamic = (bonus :> Q.t) in\n let static = Q.(total - dynamic) in\n return (static, dynamic)) ;\n register0 ~chunked:false S.current_issuance_per_minute (fun ctxt () () ->\n let* f = current_rewards_per_minute ctxt in\n return (Tez.of_mutez_exn (Q.to_int64 f))) ;\n register0 ~chunked:false S.launch_cycle (fun ctxt () () ->\n Adaptive_issuance.launch_cycle ctxt) ;\n register0 ~chunked:false S.expected_issuance (fun ctxt () () ->\n collect_expected_rewards ~ctxt)\n\nlet total_supply ctxt block =\n RPC_context.make_call0 S.total_supply ctxt block () ()\n\nlet total_frozen_stake ctxt block =\n RPC_context.make_call0 S.total_frozen_stake ctxt block () ()\n\nlet current_yearly_rate ctxt block =\n RPC_context.make_call0 S.current_yearly_rate ctxt block () ()\n\nlet current_yearly_rate_exact ctxt block =\n RPC_context.make_call0 S.current_yearly_rate_exact ctxt block () ()\n\nlet current_yearly_rate_details ctxt block =\n RPC_context.make_call0 S.current_yearly_rate_details ctxt block () ()\n\nlet current_issuance_per_minute ctxt block =\n RPC_context.make_call0 S.current_issuance_per_minute ctxt block () ()\n\nlet launch_cycle ctxt block =\n RPC_context.make_call0 S.launch_cycle ctxt block () ()\n\nlet expected_issuance ctxt block =\n RPC_context.make_call0 S.expected_issuance ctxt block () ()\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 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\nmodule Denunciations : sig\n val denunciations :\n 'a #RPC_context.simple ->\n 'a ->\n (public_key_hash * Denunciations_repr.item) list 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 Lwt_result_syntax in\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 let*! status = Nonce.get ctxt level in\n match status with\n | Ok (Revealed nonce) -> return (Revealed nonce)\n | Ok (Unrevealed {nonce_hash; _}) -> return (Missing nonce_hash)\n | Error _ -> return Forgotten)\n\n let get ctxt block level = RPC_context.make_call1 S.get ctxt block level () ()\nend\n\nmodule Contract = Contract_services\nmodule Constants = Constants_services\nmodule Delegate = Delegate_services\nmodule Voting = Voting_services\nmodule Sapling = Sapling_services\nmodule Adaptive_issuance = Adaptive_issuance_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\nmodule Denunciations = struct\n type denunciations_with_key =\n Signature.Public_key_hash.t * Denunciations_repr.item\n\n let denunciations_with_key_encoding : denunciations_with_key Data_encoding.t =\n let open Data_encoding in\n merge_objs\n (obj1 (req \"slashed_delegate\" Signature.Public_key_hash.encoding))\n Denunciations_repr.item_encoding\n\n module S = struct\n let denunciations =\n let open Data_encoding in\n RPC_service.get_service\n ~description:\n \"Returns the denunciations for misbehavior in the current cycle.\"\n ~query:RPC_query.empty\n ~output:(list denunciations_with_key_encoding)\n RPC_path.(custom_root / \"context\" / \"denunciations\")\n end\n\n let register () =\n let open Services_registration in\n let open Lwt_result_syntax in\n register0 ~chunked:false S.denunciations (fun ctxt () () ->\n let*! r =\n Alpha_context.Delegate.For_RPC.pending_denunciations_list ctxt\n in\n return r)\n\n let denunciations ctxt block =\n RPC_context.make_call0 S.denunciations ctxt block () ()\nend\n\nlet register () =\n Contract.register () ;\n Constants.register () ;\n Delegate.register () ;\n Nonce.register () ;\n Voting.register () ;\n Sapling.register () ;\n Liquidity_baking.register () ;\n Cache.register () ;\n Adaptive_issuance.register () ;\n Denunciations.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_with_legacy_attestation_name =\n Apply_results.block_metadata_encoding_with_legacy_attestation_name\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\nlet operation_data_encoding_with_legacy_attestation_name =\n Alpha_context.Operation.protocol_data_encoding_with_legacy_attestation_name\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_receipt_encoding_with_legacy_attestation_name =\n Apply_results.operation_metadata_encoding_with_legacy_attestation_name\n\nlet operation_data_and_receipt_encoding =\n Apply_results.operation_data_and_metadata_encoding\n\nlet operation_data_and_receipt_encoding_with_legacy_attestation_name =\n Apply_results\n .operation_data_and_metadata_encoding_with_legacy_attestation_name\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 attestations *)\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\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 can_contain_preattestations mode =\n let open Result_syntax in\n match mode with\n | Construction _ | Partial_construction _ -> return_true\n | Application block_header | Partial_validation block_header ->\n (* A preexisting block, which has a complete and correct block\n header, can only contain preattestations when the locked\n round in the fitness has an actual value. *)\n let* locked_round =\n Alpha_context.Fitness.locked_round_from_raw block_header.shell.fitness\n in\n return (Option.is_some locked_round)\n\n(** Initialize the consensus rights by first slot for modes that are\n about the validation/application of a block: application, partial\n validation, and full construction.\n\n In these modes, attestations must point to the predecessor's level\n and preattestations, if any, to the block's level. *)\nlet init_consensus_rights_for_block ctxt mode ~predecessor_level =\n let open Lwt_result_syntax in\n let open Alpha_context in\n let* ctxt, attestations_map =\n Baking.attesting_rights_by_first_slot ctxt predecessor_level\n in\n let*? can_contain_preattestations = can_contain_preattestations mode in\n let* ctxt, allowed_preattestations =\n if can_contain_preattestations then\n let* ctxt, preattestations_map =\n Baking.attesting_rights_by_first_slot ctxt (Level.current ctxt)\n in\n return (ctxt, Some preattestations_map)\n else return (ctxt, None)\n in\n let ctxt =\n Consensus.initialize_consensus_operation\n ctxt\n ~allowed_attestations:(Some attestations_map)\n ~allowed_preattestations\n in\n return ctxt\n\n(** Initialize the consensus rights for a mempool (partial\n construction mode).\n\n In the mempool, there are three allowed levels for both\n attestations and preattestations: [predecessor_level - 1] (aka the\n grandparent's level), [predecessor_level] (that is, the level of\n the mempool's head), and [predecessor_level + 1] (aka the current\n level in ctxt). *)\nlet init_consensus_rights_for_mempool ctxt ~predecessor_level =\n let open Lwt_result_syntax in\n let open Alpha_context in\n (* We don't want to compute the tables by first slot for all three\n possible levels because it is time-consuming. So we don't compute\n any [allowed_attestations] or [allowed_preattestations] tables. *)\n let ctxt =\n Consensus.initialize_consensus_operation\n ctxt\n ~allowed_attestations:None\n ~allowed_preattestations:None\n in\n (* However, we want to ensure that the cycle rights are loaded in\n the context, so that {!Stake_distribution.slot_owner} doesn't\n have to initialize them each time it is called (we do this now\n because the context is discarded at the end of the validation of\n each operation, so we can't rely on the caching done by\n [slot_owner] itself). *)\n let cycle = (Level.current ctxt).cycle in\n let* ctxt = Stake_distribution.load_sampler_for_cycle ctxt cycle in\n (* If the cycle has changed between the grandparent level and the\n current level, we also initialize the sampler for that\n cycle. That way, all three allowed levels are covered. *)\n match Level.pred ctxt predecessor_level with\n | Some gp_level when Cycle.(gp_level.cycle <> cycle) ->\n Stake_distribution.load_sampler_for_cycle ctxt gp_level.cycle\n | Some _ | None -> return ctxt\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 let* ctxt = Delegate.prepare_stake_distribution ctxt in\n let* ctxt =\n match mode with\n | Application _ | Partial_validation _ | Construction _ ->\n init_consensus_rights_for_block ctxt mode ~predecessor_level\n | Partial_construction _ ->\n init_consensus_rights_for_mempool ctxt ~predecessor_level\n in\n return\n ( ctxt,\n migration_balance_updates,\n migration_operation_results,\n predecessor_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 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 return\n (Validate.begin_partial_construction\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_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 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_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 open Lwt_result_syntax in\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_smart_contract (ctxt : Alpha_context.context)\n (script : Alpha_context.Script.t) =\n let allow_forged_tickets_in_storage, allow_forged_lazy_storage_id_in_storage\n =\n (false, false)\n (* There should be no forged value in bootstrap contracts. *)\n in\n let* Ex_script (Script parsed_script), ctxt =\n Script_ir_translator.parse_script\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged_tickets_in_storage\n ~allow_forged_lazy_storage_id_in_storage\n script\n in\n let* storage, lazy_storage_diff, 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 in\n let+ storage, ctxt =\n Script_ir_translator.unparse_data\n ctxt\n Optimized\n parsed_script.storage_type\n storage\n in\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 let*? raw_level = Alpha_context.Raw_level.of_int32 level in\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 let* ctxt =\n Alpha_context.prepare_first_block\n chain_id\n ~typecheck_smart_contract\n ~typecheck_smart_rollup:\n Sc_rollup_operations.validate_untyped_parameters_ty\n ~level\n ~timestamp\n ~predecessor\n ctxt\n in\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 per_block_votes =\n {\n liquidity_baking_vote =\n Alpha_context.Per_block_votes.Per_block_vote_pass;\n adaptive_issuance_vote =\n Alpha_context.Per_block_votes.Per_block_vote_pass;\n };\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 let*! ctxt = Alpha_context.Cache.Admin.sync ctxt cache_nonce in\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 open Lwt_result_syntax in\n let level = Int32.succ pred_level in\n let* ctxt, _, _ =\n Alpha_context.prepare ctxt ~level ~predecessor_timestamp ~timestamp\n in\n 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 (* 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 return\n (init\n ctxt\n chain_id\n ~predecessor_level:head_level\n ~predecessor_round\n ~predecessor_hash:head_hash)\nend\n\n(* Vanity nonce: 8669992433146046 *)\n" ;
}] ;
}
end
module Registered =
Tezos_protocol_updater.Registered_protocol.Register_embedded_V12
(Tezos_protocol_020_PsParisC.Environment)
(Tezos_protocol_020_PsParisC.Protocol.Main)
(Source)