From f831793fbdae91bdf2f5e07fb89688bcc6de6562 Mon Sep 17 00:00:00 2001 From: galfour Date: Thu, 5 Sep 2019 15:21:01 +0200 Subject: [PATCH] y e s s s --- src/ast_simplified/dune | 2 +- src/ast_simplified/types.ml | 2 +- src/ast_typed/dune | 2 +- src/ast_typed/types.ml | 2 +- src/bin/dune | 2 +- src/compiler/compiler_environment.ml | 154 +- src/compiler/compiler_program.ml | 13 +- src/compiler/compiler_type.ml | 70 +- src/compiler/dune | 4 +- src/compiler/uncompiler.ml | 4 +- src/dune | 5 +- src/main/dune | 2 +- src/main/run_mini_c.ml | 7 +- src/main/run_source.ml | 6 +- src/meta_michelson/alpha_wrap.ml | 30 - src/meta_michelson/contract.ml | 317 -- src/meta_michelson/dune | 11 - src/meta_michelson/json.ml | 7 - src/meta_michelson/meta_michelson.ml | 12 - src/meta_michelson/michelson_wrap.ml | 514 --- src/meta_michelson/misc.ml | 302 -- src/meta_michelson/streams.ml | 18 - src/mini_c/dune | 3 +- src/mini_c/types.ml | 2 +- src/operators/dune | 2 +- src/parser/camligo/dune | 2 +- src/parser/dune | 2 +- src/simplify/dune | 2 +- src/test/dune | 2 +- src/transpiler/dune | 2 +- src/typer/dune | 2 +- .../memory-proto-alpha/dune-project | 2 + vendors/ligo-utils/proto-alpha-utils/cast.ml | 195 +- vendors/ligo-utils/proto-alpha-utils/dune | 1 + .../proto-alpha-utils/init_proto_alpha.ml | 17 +- .../proto-alpha-utils/proto-alpha-utils.opam | 1 + .../proto-alpha-utils/x_memory_proto_alpha.ml | 937 ++++- .../ligo-utils/simple-utils/simple-utils.opam | 1 + .../.ocamlformat | 11 + .../default_parameters.ml | 146 + .../default_parameters.mli | 45 + .../tezos-protocol-alpha-parameters/dune | 44 + .../dune-project | 2 + .../tezos-protocol-alpha-parameters/gen.ml | 61 + .../tezos-protocol-alpha-parameters.opam | 21 + .../tezos-protocol-alpha/.ocamlformat | 11 + .../tezos-protocol-alpha/.ocamlformat-ignore | 120 + .../tezos-protocol-alpha/TEZOS_PROTOCOL | 81 + .../tezos-protocol-alpha/alpha_context.ml | 186 + .../tezos-protocol-alpha/alpha_context.mli | 1164 ++++++ .../tezos-protocol-alpha/alpha_services.ml | 127 + .../tezos-protocol-alpha/alpha_services.mli | 55 + .../tezos-protocol-alpha/amendment.ml | 275 ++ .../tezos-protocol-alpha/amendment.mli | 79 + .../ligo-utils/tezos-protocol-alpha/apply.ml | 1072 ++++++ .../tezos-protocol-alpha/apply_results.ml | 988 +++++ .../tezos-protocol-alpha/apply_results.mli | 167 + .../ligo-utils/tezos-protocol-alpha/baking.ml | 296 ++ .../tezos-protocol-alpha/baking.mli | 108 + .../blinded_public_key_hash.ml | 51 + .../blinded_public_key_hash.mli | 38 + .../tezos-protocol-alpha/block_header_repr.ml | 138 + .../block_header_repr.mli | 60 + .../tezos-protocol-alpha/bootstrap_storage.ml | 128 + .../bootstrap_storage.mli | 40 + .../tezos-protocol-alpha/commitment_repr.ml | 40 + .../tezos-protocol-alpha/commitment_repr.mli | 31 + .../commitment_storage.ml | 33 + .../commitment_storage.mli | 37 + .../tezos-protocol-alpha/constants_repr.ml | 236 ++ .../constants_services.ml | 65 + .../constants_services.mli | 35 + .../tezos-protocol-alpha/constants_storage.ml | 90 + .../tezos-protocol-alpha/contract_hash.ml | 37 + .../tezos-protocol-alpha/contract_repr.ml | 212 ++ .../tezos-protocol-alpha/contract_repr.mli | 79 + .../tezos-protocol-alpha/contract_services.ml | 273 ++ .../contract_services.mli | 86 + .../tezos-protocol-alpha/contract_storage.ml | 526 +++ .../tezos-protocol-alpha/contract_storage.mli | 140 + .../tezos-protocol-alpha/cycle_repr.ml | 85 + .../tezos-protocol-alpha/cycle_repr.mli | 44 + .../tezos-protocol-alpha/delegate_services.ml | 553 +++ .../delegate_services.mli | 176 + .../tezos-protocol-alpha/delegate_storage.ml | 626 ++++ .../tezos-protocol-alpha/delegate_storage.mli | 187 + vendors/ligo-utils/tezos-protocol-alpha/dune | 20 + .../tezos-protocol-alpha/dune-project | 2 + .../ligo-utils/tezos-protocol-alpha/dune.inc | 109 + .../tezos-protocol-alpha/fees_storage.ml | 111 + .../tezos-protocol-alpha/fees_storage.mli | 46 + .../tezos-protocol-alpha/fitness_repr.ml | 61 + .../tezos-protocol-alpha/fitness_storage.ml | 29 + .../tezos-protocol-alpha/gas_limit_repr.ml | 208 ++ .../tezos-protocol-alpha/gas_limit_repr.mli | 54 + .../tezos-protocol-alpha/helpers_services.ml | 635 ++++ .../tezos-protocol-alpha/helpers_services.mli | 211 ++ .../tezos-protocol-alpha/init_storage.ml | 51 + .../tezos-protocol-alpha/level_repr.ml | 148 + .../tezos-protocol-alpha/level_repr.mli | 69 + .../tezos-protocol-alpha/level_storage.ml | 112 + .../tezos-protocol-alpha/level_storage.mli | 44 + .../ligo-utils/tezos-protocol-alpha/main.ml | 308 ++ .../ligo-utils/tezos-protocol-alpha/main.mli | 67 + .../tezos-protocol-alpha/manager_repr.ml | 60 + .../tezos-protocol-alpha/manager_repr.mli | 38 + .../tezos-protocol-alpha/michelson_v1_gas.ml | 436 +++ .../tezos-protocol-alpha/michelson_v1_gas.mli | 200 + .../michelson_v1_primitives.ml | 597 +++ .../michelson_v1_primitives.mli | 152 + .../ligo-utils/tezos-protocol-alpha/misc.ml | 95 + .../ligo-utils/tezos-protocol-alpha/misc.mli | 44 + .../tezos-protocol-alpha/nonce_hash.ml | 37 + .../tezos-protocol-alpha/nonce_storage.ml | 121 + .../tezos-protocol-alpha/nonce_storage.mli | 57 + .../tezos-protocol-alpha/operation_repr.ml | 765 ++++ .../tezos-protocol-alpha/operation_repr.mli | 232 ++ .../tezos-protocol-alpha/parameters_repr.ml | 298 ++ .../tezos-protocol-alpha/parameters_repr.mli | 48 + .../tezos-protocol-alpha/period_repr.ml | 78 + .../tezos-protocol-alpha/period_repr.mli | 46 + .../tezos-protocol-alpha/qty_repr.ml | 313 ++ .../tezos-protocol-alpha/raw_context.ml | 652 ++++ .../tezos-protocol-alpha/raw_context.mli | 253 ++ .../tezos-protocol-alpha/raw_level_repr.ml | 90 + .../tezos-protocol-alpha/raw_level_repr.mli | 47 + .../tezos-protocol-alpha/roll_repr.ml | 61 + .../tezos-protocol-alpha/roll_repr.mli | 42 + .../tezos-protocol-alpha/roll_storage.ml | 515 +++ .../tezos-protocol-alpha/roll_storage.mli | 104 + .../tezos-protocol-alpha/script_expr_hash.ml | 36 + .../tezos-protocol-alpha/script_int_repr.ml | 87 + .../tezos-protocol-alpha/script_int_repr.mli | 143 + .../script_interpreter.ml | 891 +++++ .../script_interpreter.mli | 67 + .../tezos-protocol-alpha/script_ir_annot.ml | 413 +++ .../tezos-protocol-alpha/script_ir_annot.mli | 161 + .../script_ir_translator.ml | 3236 +++++++++++++++++ .../script_ir_translator.mli | 154 + .../tezos-protocol-alpha/script_repr.ml | 197 + .../tezos-protocol-alpha/script_repr.mli | 71 + .../tezos-protocol-alpha/script_tc_errors.ml | 84 + .../script_tc_errors_registration.ml | 622 ++++ .../script_timestamp_repr.ml | 64 + .../script_timestamp_repr.mli | 49 + .../tezos-protocol-alpha/script_typed_ir.ml | 401 ++ .../tezos-protocol-alpha/seed_repr.ml | 139 + .../tezos-protocol-alpha/seed_repr.mli | 99 + .../tezos-protocol-alpha/seed_storage.ml | 124 + .../tezos-protocol-alpha/seed_storage.mli | 44 + .../services_registration.ml | 94 + .../tezos-protocol-alpha/state_hash.ml | 37 + .../tezos-protocol-alpha/storage.ml | 609 ++++ .../tezos-protocol-alpha/storage.mli | 330 ++ .../storage_description.ml | 306 ++ .../storage_description.mli | 82 + .../tezos-protocol-alpha/storage_functors.ml | 878 +++++ .../tezos-protocol-alpha/storage_functors.mli | 85 + .../tezos-protocol-alpha/storage_sigs.ml | 392 ++ .../tezos-protocol-alpha/tez_repr.ml | 33 + .../tezos-protocol-alpha/tez_repr.mli | 29 + .../tezos-embedded-protocol-alpha.opam | 27 + .../tezos-protocol-alpha-tests.opam | 32 + .../tezos-protocol-alpha.opam | 26 + .../tezos-protocol-alpha/time_repr.ml | 54 + .../tezos-protocol-alpha/time_repr.mli | 34 + .../tezos-protocol-alpha/vote_repr.ml | 50 + .../tezos-protocol-alpha/vote_repr.mli | 32 + .../tezos-protocol-alpha/vote_storage.ml | 138 + .../tezos-protocol-alpha/vote_storage.mli | 96 + .../voting_period_repr.ml | 82 + .../voting_period_repr.mli | 48 + .../tezos-protocol-alpha/voting_services.ml | 138 + .../tezos-protocol-alpha/voting_services.mli | 49 + .../tezos-utils/michelson-parser/v1.ml | 1 + .../tezos-utils/michelson-parser/v1.mli | 2 +- .../ligo-utils/tezos-utils/tezos-utils.opam | 2 - vendors/ligo-utils/tezos-utils/x_michelson.ml | 6 +- 178 files changed, 28767 insertions(+), 1437 deletions(-) delete mode 100644 src/meta_michelson/alpha_wrap.ml delete mode 100644 src/meta_michelson/contract.ml delete mode 100644 src/meta_michelson/dune delete mode 100644 src/meta_michelson/json.ml delete mode 100644 src/meta_michelson/meta_michelson.ml delete mode 100644 src/meta_michelson/michelson_wrap.ml delete mode 100644 src/meta_michelson/misc.ml delete mode 100644 src/meta_michelson/streams.ml create mode 100644 vendors/ligo-utils/memory-proto-alpha/dune-project create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/.ocamlformat create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/dune create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat-ignore create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/amendment.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/amendment.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/apply.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/baking.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/baking.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/dune create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/dune-project create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/dune.inc create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/main.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/main.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/manager_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/misc.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/misc.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli diff --git a/src/ast_simplified/dune b/src/ast_simplified/dune index b3a3f0f44..922e2d466 100644 --- a/src/ast_simplified/dune +++ b/src/ast_simplified/dune @@ -6,7 +6,7 @@ tezos-utils ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -open Simple_utils )) ) diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index 3eb0990cb..88b93beda 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -92,7 +92,7 @@ and literal = | Literal_bytes of bytes | Literal_address of string | Literal_timestamp of int - | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation + | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation and 'a matching = | Match_bool of { diff --git a/src/ast_typed/dune b/src/ast_typed/dune index ed65217e9..a74add3b6 100644 --- a/src/ast_typed/dune +++ b/src/ast_typed/dune @@ -7,7 +7,7 @@ ast_simplified ; Is that a good idea? ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -open Simple_utils)) ) diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index 65524fde8..cf8c40fec 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -122,7 +122,7 @@ and literal = | Literal_string of string | Literal_bytes of bytes | Literal_address of string - | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation + | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation and access = | Access_tuple of int diff --git a/src/bin/dune b/src/bin/dune index b970a8805..1e08c1acf 100644 --- a/src/bin/dune +++ b/src/bin/dune @@ -8,7 +8,7 @@ ) (package ligo) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -open Simple_utils)) ) diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index d5734c4e9..dc145c7a9 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -3,12 +3,9 @@ open Trace open Mini_c open Environment open Michelson -open Memory_proto_alpha.Script_ir_translator - -module Stack = Meta_michelson.Stack let get : environment -> string -> michelson result = fun e s -> - let%bind (type_value , position) = + let%bind (_type_value , position) = let error = let title () = "Environment.get" in let content () = Format.asprintf "%s in %a" @@ -26,22 +23,10 @@ let get : environment -> string -> michelson result = fun e s -> in let code = aux position in - let%bind () = - let error () = ok @@ simple_error "error producing Env.get" in - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let output_stack_ty = Stack.(ty @: input_stack_ty) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code let set : environment -> string -> michelson result = fun e s -> - let%bind (type_value , position) = + let%bind (_type_value , position) = generic_try (simple_error "Environment.get") @@ (fun () -> Environment.get_i s e) in let rec aux = fun n -> @@ -54,37 +39,11 @@ let set : environment -> string -> michelson result = fun e s -> in let code = aux position in - let%bind () = - let error () = ok @@ simple_error "error producing Env.set" in - let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let input_stack_ty = Stack.(ty @: env_stack_ty) in - let output_stack_ty = env_stack_ty in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code -let add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) -> +let add : environment -> (string * type_value) -> michelson result = fun _e (_s , _type_value) -> let code = seq [] in - let%bind () = - let error () = ok @@ simple_error "error producing Env.get" in - let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let input_stack_ty = Stack.(ty @: env_stack_ty) in - let output_stack_ty = Stack.(ty @: env_stack_ty) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code let select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst -> @@ -111,32 +70,6 @@ let select ?(rev = false) ?(keep = true) : environment -> string list -> michels in List.fold_right' aux (seq []) e_lst in - let%bind () = - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let e' = - Environment.of_list - @@ List.map fst - @@ List.filter snd - @@ e_lst - in - let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in - let error () = - let title () = "error producing Env.select" in - let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n" - PP.environment e - PP.environment e' - PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst - Michelson.pp code - (L.get ()) - in - ok @@ (error title content) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code let select_env : environment -> environment -> michelson result = fun source filter -> @@ -158,23 +91,6 @@ let pack : environment -> michelson result = fun e -> Assert.assert_true (List.length e <> 0) in let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in - let%bind () = - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let repr = Environment.closure_representation e in - let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ repr in - let output_stack_ty = Stack.(output_ty @: nil) in - let error () = - let title () = "error producing Env.pack" in - let content () = Format.asprintf "" - in - ok @@ (error title content) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code let unpack : environment -> michelson result = fun e -> @@ -192,26 +108,6 @@ let unpack : environment -> michelson result = fun e -> ] in let code = aux l in - let%bind () = - let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e in - let repr = Environment.closure_representation e in - let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ repr in - let input_stack_ty = Stack.(input_ty @: nil) in - let error () = - let title () = "error producing Env.unpack" in - let content () = Format.asprintf "\nEnvironment:%a\nType Representation:%a\nCode:%a\n" - PP.environment e - PP.type_ repr - Michelson.pp code - in - ok @@ (error title content) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code @@ -239,53 +135,11 @@ let pack_select : environment -> string list -> michelson result = fun e lst -> in List.fold_right' aux (true , seq []) e_lst in - let%bind () = - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let e' = - Environment.of_list - @@ List.map fst - @@ List.filter snd - @@ e_lst - in - let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in - let output_stack_ty = Stack.(output_ty @: input_stack_ty) in - let error () = - let title () = "error producing Env.pack_select" in - let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n" - PP.environment e - PP.environment e' - PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst - Michelson.pp code - (L.get ()) - in - ok @@ (error title content) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code -let add_packed_anon : environment -> type_value -> michelson result = fun e type_value -> +let add_packed_anon : environment -> type_value -> michelson result = fun _e _type_value -> let code = seq [i_pair] in - let%bind () = - let error () = ok @@ simple_error "error producing add packed" in - let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in - let e' = Environment.add ("_add_packed_anon" , type_value) e in - let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let input_stack_ty = Stack.(ty @: input_ty @: nil) in - let output_stack_ty = Stack.(output_ty @: nil) in - let%bind _ = - Trace.trace_tzresult_lwt_r error @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty in - ok () - in - ok code let pop : environment -> environment result = fun e -> diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index aa737a071..329aae692 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -2,10 +2,8 @@ open Trace open Mini_c open Michelson -module Stack = Meta_michelson.Stack -module Contract_types = Meta_michelson.Types -open Memory_proto_alpha.Script_ir_translator +open Memory_proto_alpha.Protocol.Script_ir_translator open Operators.Compiler @@ -141,9 +139,9 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m else ok end_env ) in - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in + let%bind (Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in let%bind output_type = Compiler_type.type_ ty in - let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in + let%bind (Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in let error_message () = let%bind schema_michelsons = Compiler_type.environment env in ok @@ Format.asprintf @@ -470,10 +468,11 @@ and translate_quote_body ({result ; binder ; input} as f:anon_function) : michel ] in let%bind _assert_type = + let open Memory_proto_alpha.Protocol.Script_typed_ir in let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in - let input_stack_ty = Stack.(input_ty @: nil) in - let output_stack_ty = Stack.(output_ty @: nil) in + let input_stack_ty = Item_t (input_ty, Empty_t, None) in + let output_stack_ty = Item_t (output_ty, Empty_t, None) in let error_message () = Format.asprintf "\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n" diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 5977db461..61fbac6f5 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -2,18 +2,52 @@ open Trace open Mini_c.Types open Proto_alpha_utils.Memory_proto_alpha +open Protocol open Script_ir_translator module O = Tezos_utils.Michelson -module Contract_types = Meta_michelson.Types module Ty = struct let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) () let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) () + open Script_typed_ir + + + let nat_k = Nat_key None + let tez_k = Mutez_key None + let int_k = Int_key None + let string_k = String_key None + let address_k = Address_key None + let timestamp_k = Timestamp_key None + let bytes_k = Bytes_key None + (* let timestamp_k = Timestamp_key None *) + + let unit = Unit_t None + let bytes = Bytes_t None + let nat = Nat_t None + let tez = Mutez_t None + let int = Int_t None + let big_map k v = Big_map_t (k, v, None) + let signature = Signature_t None + let operation = Operation_t None + let bool = Bool_t None + let mutez = Mutez_t None + let string = String_t None + let key = Key_t None + let list a = List_t (a, None) + let set a = Set_t (a, None) + let address = Address_t None + let option a = Option_t ((a, None), None, None) + let contract a = Contract_t (a, None) + let lambda a b = Lambda_t (a, b, None) + let timestamp = Timestamp_t None + let map a b = Map_t (a, b, None) + let pair a b = Pair_t ((a, None, None), (b, None, None), None) + let union a b = Union_t ((a, None), (b, None), None) + let comparable_type_base : type_base -> ex_comparable_ty result = fun tb -> - let open Contract_types in let return x = ok @@ Ex_comparable_ty x in match tb with | Base_unit -> fail (not_comparable "unit") @@ -42,7 +76,6 @@ module Ty = struct | T_contract _ -> fail (not_comparable "contract") let base_type : type_base -> ex_ty result = fun b -> - let open Contract_types in let return x = ok @@ Ex_ty x in match b with | Base_unit -> return unit @@ -63,57 +96,56 @@ module Ty = struct | T_pair (t, t') -> ( type_ t >>? fun (Ex_ty t) -> type_ t' >>? fun (Ex_ty t') -> - ok @@ Ex_ty (Contract_types.pair t t') + ok @@ Ex_ty (pair t t') ) | T_or (t, t') -> ( type_ t >>? fun (Ex_ty t) -> type_ t' >>? fun (Ex_ty t') -> - ok @@ Ex_ty (Contract_types.union t t') + ok @@ Ex_ty (union t t') ) | T_function (arg, ret) -> let%bind (Ex_ty arg) = type_ arg in let%bind (Ex_ty ret) = type_ ret in - ok @@ Ex_ty (Contract_types.lambda arg ret) + ok @@ Ex_ty (lambda arg ret) | T_deep_closure (c, arg, ret) -> let%bind (Ex_ty capture) = environment_representation c in let%bind (Ex_ty arg) = type_ arg in let%bind (Ex_ty ret) = type_ ret in - ok @@ Ex_ty Contract_types.(pair (lambda (pair arg capture) ret) capture) + ok @@ Ex_ty (pair (lambda (pair arg capture) ret) capture) | T_map (k, v) -> let%bind (Ex_comparable_ty k') = comparable_type k in let%bind (Ex_ty v') = type_ v in - ok @@ Ex_ty Contract_types.(map k' v') + ok @@ Ex_ty (map k' v') | T_list t -> let%bind (Ex_ty t') = type_ t in - ok @@ Ex_ty Contract_types.(list t') + ok @@ Ex_ty (list t') | T_set t -> ( let%bind (Ex_comparable_ty t') = comparable_type t in - ok @@ Ex_ty Contract_types.(set t') + ok @@ Ex_ty (set t') ) | T_option t -> let%bind (Ex_ty t') = type_ t in - ok @@ Ex_ty Contract_types.(option t') + ok @@ Ex_ty (option t') | T_contract t -> let%bind (Ex_ty t') = type_ t in - ok @@ Ex_ty Contract_types.(contract t') + ok @@ Ex_ty (contract t') and environment_representation = function - | [] -> ok @@ Ex_ty Contract_types.unit + | [] -> ok @@ Ex_ty unit | [a] -> type_ @@ snd a | a::b -> let%bind (Ex_ty a) = type_ @@ snd a in let%bind (Ex_ty b) = environment_representation b in - ok @@ Ex_ty (Contract_types.pair a b) + ok @@ Ex_ty (pair a b) - and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env -> - let open Meta_michelson in + and environment : environment -> ex_stack_ty result = fun env -> let%bind lst = bind_map_list type_ @@ List.map snd env in - let aux (Stack.Ex_stack_ty st) (Ex_ty cur) = - Stack.Ex_stack_ty (Stack.stack cur st) + let aux (Ex_stack_ty st) (Ex_ty cur) = + Ex_stack_ty (Item_t (cur, st, None)) in - ok @@ List.fold_right' aux (Ex_stack_ty Stack.nil) lst + ok @@ List.fold_right' aux (Ex_stack_ty Empty_t) lst end diff --git a/src/compiler/dune b/src/compiler/dune index 5f94875b8..5e4412d81 100644 --- a/src/compiler/dune +++ b/src/compiler/dune @@ -3,13 +3,13 @@ (public_name ligo.compiler) (libraries simple-utils + proto-alpha-utils tezos-utils - meta_michelson mini_c operators ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) ) diff --git a/src/compiler/uncompiler.ml b/src/compiler/uncompiler.ml index 8453c6c5a..a26cccc20 100644 --- a/src/compiler/uncompiler.ml +++ b/src/compiler/uncompiler.ml @@ -1,6 +1,8 @@ open Mini_c.Types -open Memory_proto_alpha +open Proto_alpha_utils.Memory_proto_alpha +open X open Proto_alpha_utils.Trace +open Protocol open Script_typed_ir open Script_ir_translator diff --git a/src/dune b/src/dune index 3fb9b193b..c2f58b54f 100644 --- a/src/dune +++ b/src/dune @@ -6,11 +6,10 @@ simple-utils tezos-utils tezos-micheline - meta_michelson main ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) ) @@ -29,4 +28,4 @@ (name manual-test) (action (run test/manual_test.exe)) (deps (glob_files contracts/*)) -) \ No newline at end of file +) diff --git a/src/main/dune b/src/main/dune index 4135d0514..747afb217 100644 --- a/src/main/dune +++ b/src/main/dune @@ -15,7 +15,7 @@ compiler ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) ) diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index 5c8f12e5d..7705a2b93 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -2,7 +2,8 @@ open Proto_alpha_utils open Trace open Mini_c open! Compiler.Program -open Memory_proto_alpha.Script_ir_translator +open Memory_proto_alpha.Protocol.Script_ir_translator +open Memory_proto_alpha.X let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = let Compiler.Program.{input;output;body} : compiled_program = program in @@ -15,8 +16,8 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Memory_proto_alpha.parse_michelson body - (Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in - let open! Memory_proto_alpha.Script_interpreter in + (Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in + let open! Memory_proto_alpha.Protocol.Script_interpreter in let%bind (Item(output, Empty)) = Trace.trace_tzresult_lwt (simple_error "error of execution") @@ Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in diff --git a/src/main/run_source.ml b/src/main/run_source.ml index a0a18be96..89afbc305 100644 --- a/src/main/run_source.ml +++ b/src/main/run_source.ml @@ -259,7 +259,7 @@ let run_contract ?amount source_filename entry_point storage input syntax = parsify_expression syntax input in let options = let open Proto_alpha_utils.Memory_proto_alpha in - let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in + let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in (make_options ?amount ()) in Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) @@ -271,7 +271,7 @@ let run_function ?amount source_filename entry_point parameter syntax = parsify_expression syntax parameter in let options = let open Proto_alpha_utils.Memory_proto_alpha in - let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in + let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in (make_options ?amount ()) in Run_simplified.run_simplityped ~options typed entry_point parameter' @@ -281,6 +281,6 @@ let evaluate_value ?amount source_filename entry_point syntax = type_file syntax source_filename in let options = let open Proto_alpha_utils.Memory_proto_alpha in - let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in + let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in (make_options ?amount ()) in Run_simplified.evaluate_simplityped ~options typed entry_point diff --git a/src/meta_michelson/alpha_wrap.ml b/src/meta_michelson/alpha_wrap.ml deleted file mode 100644 index b456ea335..000000000 --- a/src/meta_michelson/alpha_wrap.ml +++ /dev/null @@ -1,30 +0,0 @@ -open Proto_alpha_utils.Error_monad - -let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment () - -let tc = dummy_environment.tezos_context - -module Proto_alpha = Proto_alpha_utils.Memory_proto_alpha -open Proto_alpha -open Alpha_context -open Alpha_environment - -let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v -let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes -> - force_lwt ~msg:"unpacking : parse" ( - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> return None - | Some expr -> - Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x)) - else - return None - ) - -let unpack ty a = match unpack_opt ty a with - | None -> raise @@ Failure "unpacking : of_bytes" - | Some x -> x - -let blake2b b = Alpha_environment.Raw_hashes.blake2b b diff --git a/src/meta_michelson/contract.ml b/src/meta_michelson/contract.ml deleted file mode 100644 index a9174a098..000000000 --- a/src/meta_michelson/contract.ml +++ /dev/null @@ -1,317 +0,0 @@ -open Misc - -open Proto_alpha_utils.Error_monad -open Memory_proto_alpha -open Alpha_context - -open Script_ir_translator -open Script_typed_ir - -module Option = Simple_utils.Option -module Cast = Proto_alpha_utils.Cast - -type ('param, 'storage) toplevel = { - param_type : 'param ty ; - storage_type : 'storage ty ; - code : ('param * 'storage, packed_internal_operation list * 'storage) lambda -} - -type ex_toplevel = - Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel - -let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type = - let toplevel_str = Streams.read_file toplevel_path in - contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } -> - let toplevel_expr = Cast.tl_of_string toplevel_str in - let (param_ty_node, storage_ty_node, code_field) = - force_ok_alpha ~msg:"parsing toplevel" @@ - parse_toplevel toplevel_expr in - let (Ex_ty param_type, _) = - force_ok_alpha ~msg:"parse arg ty" @@ - Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in - let (Ex_ty storage_type, _) = - force_ok_alpha ~msg:"parse storage ty" @@ - parse_storage_ty context storage_ty_node in - let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in - let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in - let param_type_full = Pair_t ((claimed_parameter_type, None, None), - (claimed_storage_type, None, None), None) in - let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (claimed_storage_type, None, None), None) in - parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type }) - context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) -> - Error_monad.return { - param_type = claimed_parameter_type; - storage_type = claimed_storage_type; - code ; - } - -let make_toplevel code storage_type param_type = - { param_type ; storage_type ; code } - -module type ENVIRONMENT = sig - val identities : identity list - val tezos_context : t -end - -type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack - -open Error_monad - -module Step (Env: ENVIRONMENT) = struct - open Env - - type config = { - source : Contract.t option ; - payer : Contract.t option ; - self : Contract.t option ; - visitor : (Script_interpreter.ex_descr_stack -> unit) option ; - timestamp : Script_timestamp.t option ; - debug_visitor : (ex_typed_stack -> unit) option ; - amount : Tez.t option ; - } - - let no_config = { - source = None ; - payer = None ; - self = None ; - visitor = None ; - debug_visitor = None ; - timestamp = None ; - amount = None ; - } - - let of_param base param = match param with - | None -> base - | Some _ as x -> x - - let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () = - let base_config = Option.unopt ~default:no_config base_config in { - source = Option.bind_eager_or source base_config.source ; - payer = Option.bind_eager_or payer base_config.payer ; - self = Option.bind_eager_or self base_config.self ; - visitor = Option.bind_eager_or visitor base_config.visitor ; - debug_visitor = Option.bind_eager_or debug_visitor base_config.debug_visitor ; - timestamp = Option.bind_eager_or timestamp base_config.timestamp ; - amount = Option.bind_eager_or amount base_config.amount ; - } - - open Error_monad - - let debug_visitor ?f () = - let open Script_interpreter in - let aux (Ex_descr_stack (descr, stack)) = - (match (descr.instr, descr.bef) with - | Nop, Item_t (String_t _, stack_ty, _) -> ( - let (Item (s, stack)) = stack in - if s = "_debug" - then ( - match f with - | None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack - | Some f -> f (Ex_typed_stack(stack_ty, stack)) - ) else () - ) - | _ -> ()) ; - () in - aux - - let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) = - let source = Option.unopt - ~default:(List.nth identities 0).implicit_contract config.source in - let payer = Option.unopt - ~default:(List.nth identities 1).implicit_contract config.payer in - let self = Option.unopt - ~default:(List.nth identities 2).implicit_contract config.self in - let amount = Option.unopt ~default:(Tez.one) config.amount in - let visitor = - let default = debug_visitor ?f:config.debug_visitor () in - Option.unopt ~default config.visitor in - let tezos_context = match config.timestamp with - | None -> tezos_context - | Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in - Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) -> - return stack - - let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) -> - return (b, c) - - let step_3_1 ?config (a:'a) (b:'b) (c:'c) - (descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) -> - return d - - let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) -> - return c - - let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) -> - return b - - let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) = - step_1_1 ?config a descr - - let step ?config stack code = - force_lwt ~msg:"running a step" @@ step_lwt ?config stack code - -end - -let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} = - let { code ; _ } : (_, _) toplevel = toplevel in - - let source = Option.unopt - ~default:(List.nth identities 0).implicit_contract source in - let payer = Option.unopt - ~default:(List.nth identities 1).implicit_contract payer in - let self = Option.unopt - ~default:(List.nth identities 2).implicit_contract self in - let amount = Tez.one in - - Script_interpreter.interp context ~source ~payer ~self amount code (param, storage) - >>=?? fun ((ops, storage), new_ctxt) -> - let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in - return (storage, ops, gas) - -let run_lwt ?source ?payer ?self toplevel storage param env = - run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) -> - return storage - -let run ?environment toplevel storage param = - contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param - -let run_node ?environment toplevel storage_node param_node = - contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} -> - let {param_type ; storage_type ; _ } = toplevel in - parse_data context param_type param_node >>=?? fun (param, _) -> - parse_data context storage_type storage_node >>=?? fun (storage, _) -> - let storage = run toplevel storage param in - unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) -> - return storage_node - -let run_str toplevel storage_str param_str = - let param_node = Cast.node_of_string param_str in - let storage_node = Cast.node_of_string storage_str in - run_node toplevel storage_node param_node - -type input = { - toplevel_path : string ; - storage : string ; - parameter : string -} - -let parse_json json_str : input = - let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in - let json = match json with - | `O json -> json - | _ -> raise @@ Failure "main_contract: not recorD" - in - let open Json in - let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in - let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in - let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in - { toplevel_path ; storage ; parameter } - -let generate_json (storage_node:Script.node) : string = - let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in - let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in - Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ; - Format.flush_str_formatter () - -module Types = struct - open Script_typed_ir - - let union a b = Union_t ((a, None), (b, None), None) - let assert_union = function - | Union_t ((a, _), (b, _), _) -> (a, b) - | _ -> assert false - - let pair a b = Pair_t ((a, None, None), (b, None, None), None) - let assert_pair = function - | Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b) - | _ -> assert false - let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with - | Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b) - | _ -> raise (Failure msg) - - let unit = Unit_t None - - let bytes = Bytes_t None - let bytes_k = Bytes_key None - - let nat = Nat_t None - let tez = Mutez_t None - let int = Int_t None - let nat_k = Nat_key None - let tez_k = Mutez_key None - let int_k = Int_key None - - let big_map k v = Big_map_t (k, v, None) - - let signature = Signature_t None - let operation = Operation_t None - - let bool = Bool_t None - - let mutez = Mutez_t None - - let string = String_t None - let string_k = String_key None - let address_k = Address_key None - - let key = Key_t None - - let list a = List_t (a, None) - let set a = Set_t (a, None) - let assert_list = function - | List_t (a, _) -> a - | _ -> assert false - - let option a = Option_t ((a, None), None, None) - let contract a = Contract_t (a, None) - let assert_option = function - | Option_t ((a, _), _, _) -> a - | _ -> assert false - - let address = Address_t None - - let lambda a b = Lambda_t (a, b, None) - let assert_lambda = function - | Lambda_t (a, b, _) -> (a, b) - | _ -> assert false - type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda - let is_lambda : type a . a ty -> ex_lambda option = function - | Lambda_t (_, _, _) as x -> Some (Ex_lambda x) - | _ -> None - - let timestamp = Timestamp_t None - let timestamp_k = Timestamp_key None - - let map a b = Map_t (a, b, None) - - let assert_type (_:'a ty) (_:'a) = () -end - -module Values = struct - let empty_map t = empty_map t - - let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = { - key_type ; value_type ; diff = empty_map comparable_key_ty ; - } - - let int n = Script_int.of_int n - - let nat n = Script_int.abs @@ Script_int.of_int n - let nat_to_int n = Option.unopt_exn @@ Script_int.to_int n - - let tez n = Option.unopt_exn @@ Tez.of_mutez @@ Int64.of_int n - - let left a = L a - - let right b = R b -end diff --git a/src/meta_michelson/dune b/src/meta_michelson/dune deleted file mode 100644 index 2ba2a8ae8..000000000 --- a/src/meta_michelson/dune +++ /dev/null @@ -1,11 +0,0 @@ -(library - (name meta_michelson) - (public_name ligo.meta_michelson) - (libraries - simple-utils - tezos-utils - proto-alpha-utils - michelson-parser - tezos-micheline - ) -) diff --git a/src/meta_michelson/json.ml b/src/meta_michelson/json.ml deleted file mode 100644 index 9ed070d0c..000000000 --- a/src/meta_michelson/json.ml +++ /dev/null @@ -1,7 +0,0 @@ -let force_record ~msg json = match json with - | `O json -> json - | _ -> raise @@ Failure ("not json record : " ^ msg) - -let force_string ~msg json = match json with - | `String str -> str - | _ -> raise @@ Failure ("not json str : " ^ msg) diff --git a/src/meta_michelson/meta_michelson.ml b/src/meta_michelson/meta_michelson.ml deleted file mode 100644 index 7e80979ed..000000000 --- a/src/meta_michelson/meta_michelson.ml +++ /dev/null @@ -1,12 +0,0 @@ -module Run = struct - open Contract - let run_lwt_full = run_lwt_full - let run_lwt = run_lwt - let run_str = run_str - let run_node = run_node - let run = run -end -module Stack = Michelson_wrap.Stack -module Values = Contract.Values -module Types = Contract.Types - diff --git a/src/meta_michelson/michelson_wrap.ml b/src/meta_michelson/michelson_wrap.ml deleted file mode 100644 index ae3034779..000000000 --- a/src/meta_michelson/michelson_wrap.ml +++ /dev/null @@ -1,514 +0,0 @@ -open Proto_alpha_utils.Memory_proto_alpha -module AC = Alpha_context - -module Types = Contract.Types -module Option = Simple_utils.Option -module MBytes = Alpha_environment.MBytes - -module Stack = struct - open Script_typed_ir - - let descr bef aft instr = - { - loc = 0 ; - bef ; aft ; instr - } - - type nonrec 'a ty = 'a ty - type 'a t = 'a stack_ty - type nonrec ('a, 'b) descr = ('a, 'b) descr - type ('a, 'b) code = ('a t) -> ('a, 'b) descr - - type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty - type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr - type ex_code = Ex_code : ('a, 'b) code -> ex_code - - let stack ?annot a b = Item_t (a, b, annot) - let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) = - let Item_t (hd, tl, _) = item in - (hd, tl) - - let nil = Empty_t - let head x = fst @@ unstack x - let tail x = snd @@ unstack x - - let seq a b bef = - let a_descr = a bef in - let b_descr = b a_descr.aft in - let aft = b_descr.aft in - descr bef aft @@ Seq (a_descr, b_descr) - - let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack - let (@|) = seq - let (@:) = stack - - let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d - - let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack - - let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc -> - descr ab.bef bc.aft @@ Seq(ab, bc) - - let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr = - let bc_descr = code ab_descr.aft in - ab_descr <:: bc_descr - -end - -open Stack - -type nat = AC.Script_int.n AC.Script_int.num -type int_num = AC.Script_int.z AC.Script_int.num -type bytes = MBytes.t -type address = AC.Contract.t Script_typed_ir.ty -type mutez = AC.Tez.t Script_typed_ir.ty - - -module Stack_ops = struct - open Script_typed_ir - let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef -> - let Item_t (ty, rest, _) = bef in - descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup - - let drop : ('a * 'rest, 'rest) code = fun bef -> - let aft = snd @@ unstack bef in - descr bef aft Drop - - let swap (bef : (('a * ('b * 'c)) stack_ty)) = - let Item_t (a, Item_t (b, rest, _), _) = bef in - descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap - - let dip code (bef : ('ty * 'rest) stack_ty) = - let Item_t (ty, rest, _) = bef in - let applied = code rest in - let aft = Item_t (ty, applied.aft, None) in - descr bef aft (Dip (code rest)) - - let noop : ('r, 'r) code = fun bef -> - descr bef bef Nop - - let exec : (_, _) code = fun bef -> - let lambda = head @@ tail bef in - let (_, ret) = Types.assert_lambda lambda in - let aft = ret @: (tail @@ tail bef) in - descr bef aft Exec - - let fail aft : ('a * 'r, 'b) code = fun bef -> - let head = fst @@ unstack bef in - descr bef aft (Failwith head) - - let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr = - let aft = Item_t (Types.string, bef, None) in - descr bef aft (Const (str)) - - let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r -> - let aft = stack (Types.option a) r in - descr r aft (Const None) - - let push_unit : ('rest, unit * 'rest) code = fun r -> - let aft = stack Types.unit r in - descr r aft (Const ()) - - let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr = - let aft = Item_t (Types.nat, bef, None) in - descr bef aft (Const (Contract.Values.nat n)) - - let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr = - let aft = Types.int @: bef in - descr bef aft (Const (Contract.Values.int n)) - - let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr = - let aft = Types.mutez @: bef in - descr bef aft (Const (Contract.Values.tez n)) - - let push_bool b : ('s, bool * 's) code = fun bef -> - let aft = stack Types.bool bef in - descr bef aft (Const b) - - let push_generic ty v : ('s, _ * 's) code = fun bef -> - let aft = stack ty bef in - descr bef aft (Const v) - - let failstring str aft = - push_string str @| fail aft - -end - -module Stack_shortcuts = struct - open Stack_ops - - let diip c x = dip (dip c) x - let diiip c x = dip (diip c) x - let diiiip c x = dip (diiip c) x - - let bubble_1 = swap - let bubble_down_1 = swap - - let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef -> - bef <. dip swap <: swap - let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef -> - bef <. swap <: dip swap - - let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef -> - bef <. diip swap <: dip swap <: swap - - let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef -> - bef <. dup <: dip code - - let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s -> - s <. keep_1 code <: swap - - let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef -> - (dup @| dip (swap @| dup @| dip (swap @| code))) bef - - let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef -> - (dip dup @| swap @| dip code) bef - - let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s -> - let aft = head d.aft @: tail s in - descr s aft d.instr - -end - -module Pair_ops = struct - let car (bef : (('a * 'b) * 'rest) Stack.t) = - let (pair, rest) = unstack bef in - let (a, _) = Contract.Types.assert_pair pair in - descr bef (stack a rest) Car - - let cdr (bef : (('a * 'b) * 'rest) Stack.t) = - let (pair, rest) = unstack bef in - let (_, b) = Contract.Types.assert_pair pair in - descr bef (stack b rest) Cdr - - let pair (bef : ('a * ('b * 'rest)) Stack.t) = - let (a, rest) = unstack bef in - let (b, rest) = unstack rest in - let aft = (Types.pair a b) @: rest in - descr bef aft Cons_pair - - open Stack_ops - let carcdr s = s <. car <: Stack_ops.dip cdr - - let cdrcar s = s <. cdr <: dip car - - let cdrcdr s = s <. cdr <: dip cdr - - let carcar s = s <. car <: dip car - - let cdar s = s <. cdr <: car - - let unpair s = s <. dup <: car <: dip cdr -end - -module Option_ops = struct - open Script_typed_ir - - let cons bef = - let (hd, tl) = unstack bef in - descr bef (stack (Contract.Types.option hd) tl) Cons_some - - let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef -> - let (a_opt, base) = unstack bef in - let a = Types.assert_option a_opt in - let target = Option.unopt ~default:(none_branch base).aft target in - descr bef target (If_none (none_branch base, some_branch (stack a base))) - - let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s -> - let (a_opt, base) = unstack s in - let a = Types.assert_option a_opt in - let target = a @: base in - cond ~target - (Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target) - Stack_ops.noop s -end - -module Union_ops = struct - open Script_typed_ir - - let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef -> - let (a, base) = unstack bef in - let aft = Types.union a b @: base in - descr bef aft Left - - let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef -> - let (b, base) = unstack bef in - let aft = Types.union a b @: base in - descr bef aft Right - - - let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef -> - let (union, base) = unstack bef in - let (a, b) = Types.assert_union union in - let code_stack = a @: base in - let aft = Option.unopt ~default:(b @: base) after in - descr bef aft (Loop_left (code code_stack)) - -end - -module Arithmetic = struct - let neq : (int_num * 'r, bool *'r) code = fun bef -> - let aft = stack Types.bool @@ snd @@ unstack bef in - descr bef aft Neq - - let neg : (int_num * 'r, int_num *'r) code = fun bef -> - let aft = stack Types.int @@ snd @@ unstack bef in - descr bef aft Neg_int - - let abs : (int_num * 'r, nat *'r) code = fun bef -> - let aft = stack Types.nat @@ snd @@ unstack bef in - descr bef aft Abs_int - - let int : (nat * 'r, int_num*'r) code = fun bef -> - let aft = stack Types.int @@ snd @@ unstack bef in - descr bef aft Int_nat - - let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef -> - let aft = stack Types.(option nat) @@ tail bef in - descr bef aft Is_nat - - let nat_neq = fun s -> (int @| neq) s - - let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) = - let (nat, rest) = unstack bef in - let rest = tail rest in - let aft = stack nat rest in - descr bef aft Add_natnat - - let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) = - let (nat, rest) = unstack bef in - let rest = tail rest in - let aft = stack nat rest in - descr bef aft Add_intint - - let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef -> - let aft = tail bef in - descr bef aft Add_tez - - let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) = - let nat = head bef in - let rest = tail @@ tail bef in - let aft = stack nat rest in - descr bef aft Mul_natnat - - let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) = - let nat = head bef in - let rest = tail @@ tail bef in - let aft = stack nat rest in - descr bef aft Mul_intint - - let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef -> - let aft = tail bef in - descr bef aft Sub_int - - let sub_natnat : (nat * (nat * 'r), int_num * 'r) code = - fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint - - let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s -> - let (n, base) = unstack @@ snd @@ unstack s in - let aft = Types.option (Types.pair n n) @: base in - descr s aft Ediv_natnat - - let ediv_tez = fun s -> - let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in - descr s aft Ediv_teznat - - open Option_ops - let force_ediv x = x <. ediv <: force_some - let force_ediv_tez x = (ediv_tez @| force_some) x - - open Pair_ops - let div x = x <. force_ediv <: car - - open Stack_ops - let div_n n s = s <. push_nat n <: swap <: div - let add_n n s = s <. push_nat n <: swap <: add_natnat - let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez - let sub_n n s = s <. push_nat n <: swap <: sub_natnat - - let force_nat s = s <. nat_opt <: force_some ~msg:"force nat" -end - -module Boolean = struct - let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef -> - let aft = Types.bool @: tail @@ tail bef in - descr bef aft And - - let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef -> - let aft = Types.bool @: tail @@ tail bef in - descr bef aft Or - - open Script_typed_ir - let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef -> - let base = tail bef in - let aft = Option.unopt ~default:((true_branch base).aft) target in - descr bef aft (If (true_branch base, false_branch base)) - - let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef -> - let aft = tail bef in - descr bef aft @@ Loop (code aft) - -end - -module Comparison_ops = struct - let cmp c_ty : _ code = fun bef -> - let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in - descr bef aft (Compare c_ty) - - let cmp_bytes = fun x -> cmp (Bytes_key None) x - - let eq : (int_num * 'r, bool *'r) code = fun bef -> - let aft = stack Contract.Types.bool @@ snd @@ unstack bef in - descr bef aft Eq - - open Arithmetic - let eq_n n s = s <. sub_n n <: eq - - let ge : (int_num * 'r, bool * 'r) code = fun bef -> - let base = tail bef in - let aft = stack Types.bool base in - descr bef aft Ge - - let gt : (int_num * 'r, bool * 'r) code = fun bef -> - let base = tail bef in - let aft = stack Types.bool base in - descr bef aft Gt - - let lt : (int_num * 'r, bool * 'r) code = fun bef -> - let base = tail bef in - let aft = stack Types.bool base in - descr bef aft Lt - - let gt_nat s = s <. int <: gt - - open Stack_ops - let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s) - - let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef -> - bef <. sub_natnat <: ge - - let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef -> - bef <. cmp Types.timestamp_k <: ge - - let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef -> - bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef)) - - let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef -> - bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef)) -end - - -module Bytes = struct - - open Script_typed_ir - - let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef -> - let aft = stack Types.bytes @@ tail bef in - descr bef aft (Pack ty) - - let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef -> - let aft = stack (Types.option ty) (tail bef) in - descr bef aft (Unpack ty) - - let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some - - let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef -> - let aft = tail bef in - descr bef aft Concat_bytes_pair - - let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef -> - descr bef bef Sha256 - - let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef -> - descr bef bef Blake2b -end - - -module Map = struct - open Script_typed_ir - - type ('a, 'b) t = ('a, 'b) map - - let empty c_ty = Script_ir_translator.empty_map c_ty - let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m - - module Ops = struct - let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr = - let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in - let aft = Item_t (map, rest, None) in - descr bef aft Map_update - - let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef -> - let _ = a in - let base = snd @@ unstack @@ snd @@ unstack bef in - let aft = stack (Types.option b) base in - descr bef aft Map_get - - let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef -> - let base = snd @@ unstack @@ snd @@ unstack bef in - let aft = stack (Types.option b) base in - descr bef aft Big_map_get - - let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef -> - let base = tail @@ tail bef in - descr bef base Big_map_update - end -end - -module List_ops = struct - let nil ele bef = - let aft = stack (Types.list ele) bef in - descr bef aft Nil - - let cons bef = - let aft = tail bef in - descr bef aft Cons_list - - let cond ~target cons_branch nil_branch bef = - let (lst, aft) = unstack bef in - let a = Types.assert_list lst in - let cons_descr = cons_branch (a @: Types.list a @: aft) in - let nil_descr = nil_branch aft in - descr bef target (If_cons (cons_descr, nil_descr)) - - let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef -> - let (a_lst, aft) = unstack bef in - let a = Types.assert_list a_lst in - descr bef aft (List_iter (code (a @: aft))) - -end - -module Tez = struct - - let amount : ('r, AC.Tez.t * 'r) code = fun bef -> - let aft = Types.mutez @: bef in - descr bef aft Amount - - open Bytes - - let tez_nat s = s <. pack Types.mutez <: unpack Types.nat - let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat -end - -module Misc = struct - - open Stack_ops - open Stack_shortcuts - open Comparison_ops - let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> - s <. - keep_2 cmp_ge_nat <: bubble_2 <: - Boolean.cond drop (dip drop) - - let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop - - let debug_msg msg = debug ~msg () - - let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef -> - let aft = stack Types.timestamp bef in - descr bef aft Now - -end - - - diff --git a/src/meta_michelson/misc.ml b/src/meta_michelson/misc.ml deleted file mode 100644 index af5385c14..000000000 --- a/src/meta_michelson/misc.ml +++ /dev/null @@ -1,302 +0,0 @@ -module Signature = Tezos_base.TzPervasives.Signature -open Proto_alpha_utils.Memory_proto_alpha -module Data_encoding = Alpha_environment.Data_encoding -module MBytes = Alpha_environment.MBytes -module Error_monad = Proto_alpha_utils.Error_monad -open Error_monad - -module Context_init = struct - - type account = { - pkh : Signature.Public_key_hash.t ; - pk : Signature.Public_key.t ; - sk : Signature.Secret_key.t ; - } - - let generate_accounts n : (account * Tez_repr.t) list = - let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in - List.map (fun _ -> - let (pkh, pk, sk) = Signature.generate_key () in - let account = { pkh ; pk ; sk } in - account, amount) - (Simple_utils.List.range n) - - let make_shell - ~level ~predecessor ~timestamp ~fitness ~operations_hash = - Tezos_base.Block_header.{ - level ; - predecessor ; - timestamp ; - fitness ; - operations_hash ; - (* We don't care of the following values, only the shell validates them. *) - proto_level = 0 ; - validation_passes = 0 ; - context = Alpha_environment.Context_hash.zero ; - } - - let default_proof_of_work_nonce = - MBytes.create Alpha_context.Constants.proof_of_work_nonce_size - - let protocol_param_key = [ "protocol_parameters" ] - - let check_constants_consistency constants = - let open Constants_repr in - let open Error_monad in - let { blocks_per_cycle ; blocks_per_commitment ; - blocks_per_roll_snapshot ; _ } = constants in - Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) - (fun () -> failwith "Inconsistent constants : blocks per commitment must be \ - less than blocks per cycle") >>=? fun () -> - Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) - (fun () -> failwith "Inconsistent constants : blocks per cycle \ - must be superior than blocks per roll snapshot") >>=? - return - - - let initial_context - constants - header - commitments - initial_accounts - security_deposit_ramp_up_cycles - no_reward_cycles - = - let open Tezos_base.TzPervasives.Error_monad in - let bootstrap_accounts = - List.map (fun ({ pk ; pkh ; _ }, amount) -> - let open! Parameters_repr in - { public_key_hash = pkh ; public_key = Some pk ; amount } - ) initial_accounts - in - let json = - Data_encoding.Json.construct - Parameters_repr.encoding - Parameters_repr.{ - bootstrap_accounts ; - bootstrap_contracts = [] ; - commitments ; - constants ; - security_deposit_ramp_up_cycles ; - no_reward_cycles ; - } - in - let proto_params = - Data_encoding.Binary.to_bytes_exn Data_encoding.json json - in - Tezos_protocol_environment_memory.Context.( - set empty ["version"] (MBytes.of_string "genesis") - ) >>= fun ctxt -> - Tezos_protocol_environment_memory.Context.( - set ctxt protocol_param_key proto_params - ) >>= fun ctxt -> - Main.init ctxt header - >|= Alpha_environment.wrap_error >>=? fun { context; _ } -> - return context - - let genesis - ?(preserved_cycles = Constants_repr.default.preserved_cycles) - ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle) - ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment) - ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot) - ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period) - ?(time_between_blocks = Constants_repr.default.time_between_blocks) - ?(endorsers_per_block = Constants_repr.default.endorsers_per_block) - ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation) - ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block) - ?(proof_of_work_threshold = Int64.(neg one)) - ?(tokens_per_roll = Constants_repr.default.tokens_per_roll) - ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size) - ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip) - ?(origination_size = Constants_repr.default.origination_size) - ?(block_security_deposit = Constants_repr.default.block_security_deposit) - ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit) - ?(block_reward = Constants_repr.default.block_reward) - ?(endorsement_reward = Constants_repr.default.endorsement_reward) - ?(cost_per_byte = Constants_repr.default.cost_per_byte) - ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation) - ?(commitments = []) - ?(security_deposit_ramp_up_cycles = None) - ?(no_reward_cycles = None) - (initial_accounts : (account * Tez_repr.t) list) - = - if initial_accounts = [] then - Pervasives.failwith "Must have one account with a roll to bake"; - - (* Check there is at least one roll *) - let open Tezos_base.TzPervasives.Error_monad in - begin try - let (>>?=) x y = match x with - | Ok(a) -> y a - | Error(b) -> fail @@ List.hd b in - fold_left_s (fun acc (_, amount) -> - Alpha_environment.wrap_error @@ - Tez_repr.(+?) acc amount >>?= fun acc -> - if acc >= tokens_per_roll then - raise Exit - else return acc - ) Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return () - end >>=? fun () -> - - let constants : Constants_repr.parametric = { - preserved_cycles ; - blocks_per_cycle ; - blocks_per_commitment ; - blocks_per_roll_snapshot ; - blocks_per_voting_period ; - time_between_blocks ; - endorsers_per_block ; - hard_gas_limit_per_operation ; - hard_gas_limit_per_block ; - proof_of_work_threshold ; - tokens_per_roll ; - michelson_maximum_type_size ; - seed_nonce_revelation_tip ; - origination_size ; - block_security_deposit ; - endorsement_security_deposit ; - block_reward ; - endorsement_reward ; - cost_per_byte ; - hard_storage_limit_per_operation ; - } in - check_constants_consistency constants >>=? fun () -> - - let hash = - Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" - in - let shell = make_shell - ~level:0l - ~predecessor:hash - ~timestamp:Tezos_utils.Time.epoch - ~fitness: (Fitness_repr.from_int64 0L) - ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in - initial_context - constants - shell - commitments - initial_accounts - security_deposit_ramp_up_cycles - no_reward_cycles - >>=? fun context -> - return (context, shell, hash) - - let init - ?(slow=false) - ?preserved_cycles - ?endorsers_per_block - ?commitments - n = - let open Error_monad in - let accounts = generate_accounts n in - let contracts = List.map (fun (a, _) -> - Alpha_context.Contract.implicit_contract (a.pkh)) accounts in - begin - if slow then - genesis - ?preserved_cycles - ?endorsers_per_block - ?commitments - accounts - else - genesis - ?preserved_cycles - ~blocks_per_cycle:32l - ~blocks_per_commitment:4l - ~blocks_per_roll_snapshot:8l - ~blocks_per_voting_period:(Int32.mul 32l 8l) - ?endorsers_per_block - ?commitments - accounts - end >>=? fun ctxt -> - return (ctxt, accounts, contracts) - - let contents - ?(proof_of_work_nonce = default_proof_of_work_nonce) - ?(priority = 0) ?seed_nonce_hash () = - Alpha_context.Block_header.({ - priority ; - proof_of_work_nonce ; - seed_nonce_hash ; - }) - - - let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt = - let contents = contents ~priority () in - let protocol_data = - let open! Alpha_context.Block_header in { - contents ; - signature = Signature.zero ; - } in - let header = { - Alpha_context.Block_header.shell = { - predecessor = hash ; - proto_level = header.proto_level ; - validation_passes = header.validation_passes ; - fitness = header.fitness ; - timestamp ; - level = header.level ; - context = Alpha_environment.Context_hash.zero ; - operations_hash = Alpha_environment.Operation_list_list_hash.zero ; - } ; - protocol_data = { - contents ; - signature = Signature.zero ; - } ; - } in - Main.begin_construction - ~chain_id: Alpha_environment.Chain_id.zero - ~predecessor_context: ctxt - ~predecessor_timestamp: header.shell.timestamp - ~predecessor_fitness: header.shell.fitness - ~predecessor_level: header.shell.level - ~predecessor:hash - ~timestamp - ~protocol_data - () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state -> - return state.ctxt - - let main n = - init n >>=? fun ((ctxt, header, hash), accounts, contracts) -> - let timestamp = Tezos_base.Time.now () in - begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt -> - return (ctxt, accounts, contracts) - -end - -type identity = { - public_key_hash : Signature.public_key_hash; - public_key : Signature.public_key; - secret_key : Signature.secret_key; - implicit_contract : Alpha_context.Contract.t; -} - -type environment = { - tezos_context : Alpha_context.t ; - identities : identity list ; -} - -let init_environment () = - Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) -> - let accounts = List.map fst accounts in - let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in - let identities = - List.map (fun ((a:Context_init.account), c) -> { - public_key = a.pk ; - public_key_hash = a.pkh ; - secret_key = a.sk ; - implicit_contract = c ; - }) @@ - List.combine accounts contracts in - return {tezos_context ; identities} - -let contextualize ~msg ?environment f = - let lwt = - let environment = match environment with - | None -> init_environment () - | Some x -> return x in - environment >>=? f - in - force_ok ~msg @@ Lwt_main.run lwt diff --git a/src/meta_michelson/streams.ml b/src/meta_michelson/streams.ml deleted file mode 100644 index b45176516..000000000 --- a/src/meta_michelson/streams.ml +++ /dev/null @@ -1,18 +0,0 @@ -let read_file f = - let ic = open_in f in - let n = in_channel_length ic in - let s = Bytes.create n in - really_input ic s 0 n; - close_in ic; - Bytes.to_string s - -let read_lines filename = - let lines = ref [] in - let chan = open_in filename in - try - while true; do - lines := input_line chan :: !lines - done; !lines - with End_of_file -> - close_in chan; - List.rev !lines diff --git a/src/mini_c/dune b/src/mini_c/dune index 059ce005f..d7e69d219 100644 --- a/src/mini_c/dune +++ b/src/mini_c/dune @@ -4,10 +4,9 @@ (libraries simple-utils tezos-utils - meta_michelson ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) ) diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 3e9a69819..0bc00441c 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -51,7 +51,7 @@ type value = | D_set of value list (* | `Macro of anon_macro ... The future. *) | D_function of anon_function - | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation + | D_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation and selector = var_name list diff --git a/src/operators/dune b/src/operators/dune index f19047fd0..0bd5db43d 100644 --- a/src/operators/dune +++ b/src/operators/dune @@ -8,7 +8,7 @@ mini_c ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -open Simple_utils )) ) diff --git a/src/parser/camligo/dune b/src/parser/camligo/dune index 62e28bcb6..428f10424 100644 --- a/src/parser/camligo/dune +++ b/src/parser/camligo/dune @@ -10,7 +10,7 @@ (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils )) (preprocess (pps - simple-utils.ppx_let_generalized + ppx_let ppx_deriving.std ) ) diff --git a/src/parser/dune b/src/parser/dune index 9fa014ac7..da0988ab2 100644 --- a/src/parser/dune +++ b/src/parser/dune @@ -10,7 +10,7 @@ parser_ligodity ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared )) ) diff --git a/src/simplify/dune b/src/simplify/dune index 5e4e7d88b..9649d13dc 100644 --- a/src/simplify/dune +++ b/src/simplify/dune @@ -10,7 +10,7 @@ (modules ligodity pascaligo simplify) (preprocess (pps - simple-utils.ppx_let_generalized + ppx_let ) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) diff --git a/src/test/dune b/src/test/dune index aebc6fad9..021ae172f 100644 --- a/src/test/dune +++ b/src/test/dune @@ -6,7 +6,7 @@ alcotest ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils )) ) diff --git a/src/transpiler/dune b/src/transpiler/dune index 02104ba12..3f483bda3 100644 --- a/src/transpiler/dune +++ b/src/transpiler/dune @@ -9,7 +9,7 @@ operators ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) ) diff --git a/src/typer/dune b/src/typer/dune index d9e63bf4a..0ee58cc43 100644 --- a/src/typer/dune +++ b/src/typer/dune @@ -9,7 +9,7 @@ operators ) (preprocess - (pps simple-utils.ppx_let_generalized) + (pps ppx_let) ) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) ) diff --git a/vendors/ligo-utils/memory-proto-alpha/dune-project b/vendors/ligo-utils/memory-proto-alpha/dune-project new file mode 100644 index 000000000..1cf86c9fe --- /dev/null +++ b/vendors/ligo-utils/memory-proto-alpha/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-memory-proto-alpha) diff --git a/vendors/ligo-utils/proto-alpha-utils/cast.ml b/vendors/ligo-utils/proto-alpha-utils/cast.ml index 8bb4f5eaf..cbf70180f 100644 --- a/vendors/ligo-utils/proto-alpha-utils/cast.ml +++ b/vendors/ligo-utils/proto-alpha-utils/cast.ml @@ -4,6 +4,7 @@ open Tezos_micheline let env = Error_monad.force_lwt ~msg:"Cast:init environment" @@ Init_proto_alpha.init_environment () open Memory_proto_alpha +open Protocol open Alpha_context exception Expr_from_string @@ -44,6 +45,196 @@ let node_to_string (node:_ Micheline.node) = open Script_ir_translator +type ex_typed_value = + Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value + +include struct + open Script_typed_ir + open Protocol.Environment.Error_monad + module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse + open Micheline + open Michelson_v1_primitives + open Protocol.Environment + + let rec unparse_data_generic + : type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) -> + unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t + = fun ctxt ?(mapper = fun _ -> return None) mode ty a -> + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> + mapper (Ex_typed_value (ty, a)) >>=? function + | Some x -> return (x, ctxt) + | None -> ( + match ty, a with + | Unit_t _, () -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> + return (Prim (-1, D_Unit, [], []), ctxt) + | Int_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | Nat_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | String_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> + return (String (-1, s), ctxt) + | Bytes_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> + return (Bytes (-1, s), ctxt) + | Bool_t _, true -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_True, [], []), ctxt) + | Bool_t _, false -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_False, [], []), ctxt) + | Timestamp_t _, t -> + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> + begin + match mode with + | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> + match Script_timestamp.to_notation t with + | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (-1, s), ctxt) + end + | Address_t _, c -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Contract_t _, (_, c) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Signature_t _, s -> + Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) + end + | Mutez_t _, v -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> + return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | Key_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) + end + | Key_hash_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + end + | Operation_t _, op -> + let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> + unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) + | Union_t ((tl, _), _, _), L l -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> + return (Prim (-1, D_Left, [ l ], []), ctxt) + | Union_t (_, (tr, _), _), R r -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Right, [ r ], []), ctxt) + | Option_t ((t, _), _, _), Some v -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) -> + return (Prim (-1, D_Some, [ v ], []), ctxt) + | Option_t _, None -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> + return (Prim (-1, D_None, [], []), ctxt) + | List_t (t, _), items -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) -> + return (unparsed :: l, ctxt)) + ([], ctxt) + items >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | Set_t (t, _), set -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Map_t (kt, vt, _), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), _map -> + return (Micheline.Seq (-1, []), ctxt) + | Lambda_t _, Lam (_, original_code) -> + unparse_code_generic ~mapper ctxt mode (root original_code) + ) + + and unparse_code_generic ctxt ?mapper mode = function + | Prim (loc, I_PUSH, [ ty ; data ], annot) -> + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt t data >>=? fun (data, ctxt) -> + unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> + return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) + | Seq (loc, items) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> + return (Micheline.Seq (loc, List.rev items), ctxt) + | Prim (loc, prim, items, annot) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> + return (Prim (loc, prim, List.rev items, annot), ctxt) + | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) + + +end + let rec mapper (Ex_typed_value (ty, a)) = let open Alpha_environment.Error_monad in let open Script_typed_ir in @@ -67,7 +258,7 @@ let rec mapper (Ex_typed_value (ty, a)) = and data_to_node (Ex_typed_value (ty, data)) = let tc = env.tezos_context in - let node_lwt = Script_ir_translator.unparse_data tc ~mapper Readable ty data in + let node_lwt = unparse_data_generic tc ~mapper Readable ty data in let node = fst @@ Error_monad.force_lwt_alpha ~msg:"data to string" node_lwt in node @@ -125,7 +316,7 @@ let descr_to_node x = | Car -> prim I_CAR | Cdr -> prim I_CDR | Cons_pair -> prim I_PAIR - | Nop -> prim I_NOP + | Nop -> Micheline.Seq (0, [prim I_UNIT ; prim I_DROP]) | Seq (a, b) -> Micheline.Seq (0, List.map f [Ex_descr a ; Ex_descr b]) | Const v -> ( let (Item_t (ty, _, _)) = descr.aft in diff --git a/vendors/ligo-utils/proto-alpha-utils/dune b/vendors/ligo-utils/proto-alpha-utils/dune index 1db76360b..2b43cce9e 100644 --- a/vendors/ligo-utils/proto-alpha-utils/dune +++ b/vendors/ligo-utils/proto-alpha-utils/dune @@ -4,6 +4,7 @@ (libraries tezos-error-monad tezos-stdlib-unix + tezos-protocol-alpha-parameters tezos-memory-proto-alpha simple-utils tezos-utils diff --git a/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml index 1ec930b5f..812d18b24 100644 --- a/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml @@ -4,7 +4,7 @@ module Data_encoding = Alpha_environment.Data_encoding module MBytes = Alpha_environment.MBytes module Error_monad = X_error_monad open Error_monad - +open Protocol module Context_init = struct @@ -85,10 +85,10 @@ module Context_init = struct let proto_params = Data_encoding.Binary.to_bytes_exn Data_encoding.json json in - Tezos_protocol_environment_memory.Context.( - set empty ["version"] (MBytes.of_string "genesis") + Tezos_protocol_environment.Context.( + set Memory_context.empty ["version"] (MBytes.of_string "genesis") ) >>= fun ctxt -> - Tezos_protocol_environment_memory.Context.( + Tezos_protocol_environment.Context.( set ctxt protocol_param_key proto_params ) >>= fun ctxt -> Main.init ctxt header @@ -141,7 +141,7 @@ module Context_init = struct with Exit -> return () end >>=? fun () -> - let constants : Constants_repr.parametric = { + let constants : Constants_repr.parametric = Tezos_protocol_alpha_parameters.Default_parameters.({ preserved_cycles ; blocks_per_cycle ; blocks_per_commitment ; @@ -162,7 +162,8 @@ module Context_init = struct endorsement_reward ; cost_per_byte ; hard_storage_limit_per_operation ; - } in + test_chain_duration = constants_mainnet.test_chain_duration ; + }) in check_constants_consistency constants >>=? fun () -> let hash = @@ -171,7 +172,7 @@ module Context_init = struct let shell = make_shell ~level:0l ~predecessor:hash - ~timestamp:Tezos_base.TzPervasives.Time.epoch + ~timestamp:Tezos_base.TzPervasives.Time.Protocol.epoch ~fitness: (Fitness_repr.from_int64 0L) ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in initial_context @@ -246,7 +247,7 @@ module Context_init = struct let main n = init n >>=? fun ((ctxt, header, hash), accounts, contracts) -> - let timestamp = Tezos_base.Time.now () in + let timestamp = Environment.Time.of_seconds @@ Int64.of_float @@ Unix.time () in begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt -> return (ctxt, accounts, contracts) diff --git a/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam b/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam index 042ecff48..4a4e6cfc8 100644 --- a/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam +++ b/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam @@ -39,6 +39,7 @@ depends: [ "tezos-data-encoding" "tezos-protocol-environment" "tezos-protocol-alpha" + "tezos-protocol-alpha-parameters" "michelson-parser" "simple-utils" "tezos-utils" diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index bd5f6c1fe..395be29b0 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml @@ -4,15 +4,940 @@ include Memory_proto_alpha let init_environment = Init_proto_alpha.init_environment let dummy_environment = Init_proto_alpha.dummy_environment -open X_error_monad + +open Protocol open Script_typed_ir open Script_ir_translator open Script_interpreter +module X = struct + open Alpha_context + open Script_tc_errors + open Alpha_environment.Error_monad +let rec stack_ty_eq + : type ta tb. context -> int -> ta stack_ty -> tb stack_ty -> + ((ta stack_ty, tb stack_ty) eq * context) tzresult + = fun ctxt lvl ta tb -> + match ta, tb with + | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> + ty_eq ctxt tva tvb |> + record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) -> + stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) -> + (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult) + | Empty_t, Empty_t -> Ok (Eq, ctxt) + | _, _ -> error Bad_stack_length + + open Script_typed_ir + open Protocol.Environment.Error_monad + module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse + open Tezos_micheline.Micheline + open Michelson_v1_primitives + open Protocol.Environment + + type ex_typed_value = + Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value + + + let rec unparse_data_generic + : type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) -> + unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t + = fun ctxt ?(mapper = fun _ -> return None) mode ty a -> + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> + mapper (Ex_typed_value (ty, a)) >>=? function + | Some x -> return (x, ctxt) + | None -> ( + match ty, a with + | Unit_t _, () -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> + return (Prim (-1, D_Unit, [], []), ctxt) + | Int_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | Nat_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | String_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> + return (String (-1, s), ctxt) + | Bytes_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> + return (Bytes (-1, s), ctxt) + | Bool_t _, true -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_True, [], []), ctxt) + | Bool_t _, false -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_False, [], []), ctxt) + | Timestamp_t _, t -> + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> + begin + match mode with + | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> + match Script_timestamp.to_notation t with + | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (-1, s), ctxt) + end + | Address_t _, c -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Contract_t _, (_, c) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Signature_t _, s -> + Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) + end + | Mutez_t _, v -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> + return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | Key_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) + end + | Key_hash_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + end + | Operation_t _, op -> + let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> + unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) + | Union_t ((tl, _), _, _), L l -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> + return (Prim (-1, D_Left, [ l ], []), ctxt) + | Union_t (_, (tr, _), _), R r -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Right, [ r ], []), ctxt) + | Option_t ((t, _), _, _), Some v -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) -> + return (Prim (-1, D_Some, [ v ], []), ctxt) + | Option_t _, None -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> + return (Prim (-1, D_None, [], []), ctxt) + | List_t (t, _), items -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) -> + return (unparsed :: l, ctxt)) + ([], ctxt) + items >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | Set_t (t, _), set -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Map_t (kt, vt, _), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), _map -> + return (Micheline.Seq (-1, []), ctxt) + | Lambda_t _, Lam (_, original_code) -> + unparse_code_generic ~mapper ctxt mode (root original_code) + ) + + and unparse_code_generic ctxt ?mapper mode = function + | Prim (loc, I_PUSH, [ ty ; data ], annot) -> + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt t data >>=? fun (data, ctxt) -> + unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> + return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) + | Seq (loc, items) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> + return (Micheline.Seq (loc, List.rev items), ctxt) + | Prim (loc, prim, items, annot) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> + return (Prim (loc, prim, List.rev items, annot), ctxt) + | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) + +module Interp_costs = Michelson_v1_gas.Cost_of +type ex_descr_stack = Ex_descr_stack : (('a, 'b) descr * 'a stack) -> ex_descr_stack + +let unparse_stack ctxt (stack, stack_ty) = + (* We drop the gas limit as this function is only used for debugging/errors. *) + let ctxt = Gas.set_unlimited ctxt in + let rec unparse_stack + : type a. a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t + = function + | Empty, Empty_t -> return_nil + | Item (v, rest), Item_t (ty, rest_ty, annot) -> + unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) -> + unparse_stack (rest, rest_ty) >>=? fun rest -> + let annot = match Script_ir_annot.unparse_var_annot annot with + | [] -> None + | [ a ] -> Some a + | _ -> assert false in + let data = Micheline.strip_locations data in + return ((data, annot) :: rest) in + unparse_stack (stack, stack_ty) + +let rec step + : type b a. + (?log: execution_trace ref -> + context -> + source: Contract.t -> + self: Contract.t -> + payer: Contract.t -> + ?visitor: (ex_descr_stack -> unit) -> + Tez.t -> + (b, a) descr -> b stack -> + (a stack * context) tzresult Lwt.t) = + fun ?log ctxt ~source ~self ~payer ?visitor amount ({ instr ; loc ; _ } as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> + (match visitor with + | Some visitor -> visitor @@ Ex_descr_stack(descr, stack) + | None -> ()) ; + let step_same ctxt = step ?log ctxt ~source ~self ~payer ?visitor amount in + let logged_return : type a b. + (b, a) descr -> + a stack * context -> + (a stack * context) tzresult Lwt.t = + fun descr (ret, ctxt) -> + match log with + | None -> return (ret, ctxt) + | Some log -> + trace + Cannot_serialize_log + (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> + log := (descr.loc, Gas.level ctxt, stack) :: !log ; + return (ret, ctxt) in + let get_log (log : execution_trace ref option) = + Option.map ~f:(fun l -> List.rev !l) log in + let consume_gas_terop : type ret arg1 arg2 arg3 rest. + (_ * (_ * (_ * rest)), ret * rest) descr -> + ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + (arg1 -> arg2 -> arg3 -> Gas.cost) -> + rest stack -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2 x3, rest), ctxt) in + let consume_gas_binop : type ret arg1 arg2 rest. + (_ * (_ * rest), ret * rest) descr -> + ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + (arg1 -> arg2 -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2, rest), ctxt) in + let consume_gas_unop : type ret arg rest. + (_ * rest, ret * rest) descr -> + ((arg -> ret) * arg) -> + (arg -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + logged_return descr (Item (op arg, rest), ctxt) in + let consume_gaz_comparison : + type t rest. + (t * (t * rest), Script_int.z Script_int.num * rest) descr -> + (t -> t -> int) -> + (t -> t -> Gas.cost) -> + t -> t -> + rest stack -> + ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = + fun descr op cost x1 x2 rest -> + Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in + let logged_return : + a stack * context -> + (a stack * context) tzresult Lwt.t = + logged_return descr in + match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (rest, ctxt) + | Dup, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (v, Item (v, rest)), ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (vo, Item (vi, rest)), ctxt) + | Const v, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (Some v, rest), ctxt) + | Cons_none _, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | If_none (bt, _), Item (None, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt rest + | If_none (_, bf), Item (Some v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + logged_return (Item ((a, b), rest), ctxt) + | Car, Item ((a, _), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, rest), ctxt) + | Cdr, Item ((_, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (b, rest), ctxt) + (* unions *) + | Left, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (L v, rest), ctxt) + | Right, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (R v, rest), ctxt) + | If_left (bt, _), Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + logged_return (Item (hd :: tl, rest), ctxt) + | Nil, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item ([], rest), ctxt) + | If_cons (_, bf), Item ([], rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt (Item (hd, Item (tl, rest))) + | List_map body, Item (l, rest) -> + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (Item (List.rev acc, rest), ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (hd :: acc) + in loop rest ctxt l [] >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | List_size, Item (list, rest) -> + Lwt.return + (List.fold_left + (fun acc _ -> + acc >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> + ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | List_iter body, Item (l, init) -> + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + (* sets *) + | Empty_set t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + logged_return (Item (empty_set t, rest), ctxt) + | Set_iter body, Item (set, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Set_mem, Item (v, Item (set, rest)) -> + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + | Set_update, Item (v, Item (presence, Item (set, rest))) -> + consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + | Set_size, Item (set, rest) -> + consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + (* maps *) + | Empty_map (t, _), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (empty_map t, rest), ctxt) + | Map_map body, Item (map, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt) + | (k, _) as hd :: tl -> + step_same ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Map_iter body, Item (map, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Map_mem, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + | Map_get, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + | Map_update, Item (k, Item (v, Item (map, rest))) -> + consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest + | Map_size, Item (map, rest) -> + consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + (* Big map operations *) + | Big_map_mem, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> + Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_get, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> + Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + consume_gas_terop descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + Interp_costs.big_map_update rest + (* timestamp operations *) + | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + consume_gas_binop descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + consume_gas_binop descr (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + consume_gas_binop descr (Script_timestamp.sub_delta, t, s) + Interp_costs.sub_timestamp rest ctxt + | Diff_timestamps, Item (t1, Item (t2, rest)) -> + consume_gas_binop descr (Script_timestamp.diff, t1, t2) + Interp_costs.diff_timestamps rest ctxt + (* string operations *) + | Concat_string_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> + let s = String.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_string, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_string, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | String_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | Concat_bytes_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> + let s = MBytes.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_bytes, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> + let s = MBytes.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (MBytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Bytes_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x +? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x -? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Mul_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + | Mul_nattez, Item (y, Item (x, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + | And, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + | Xor, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + | Not, Item (x, rest) -> + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + (* integer operations *) + | Is_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + | Abs_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + | Int_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + | Neg_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Neg_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Add_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + | Sub_int, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + | Mul_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + | Ediv_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + consume_gas_binop descr + ((fun x y -> + match Script_int.ediv x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 q, + Script_int.to_int64 r with + | Some q, Some r -> + begin + match Tez.of_mutez q, Tez.of_mutez r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in + consume_gas_binop descr + ((fun x y -> match Script_int.ediv_n x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_mutez r with + | None -> assert false (* Cannot overflow *) + | Some r -> Some (q, r)), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + | Lsl_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + begin + match Script_int.shift_left_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some x -> logged_return (Item (x, rest), ctxt) + end + | Lsr_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + begin + match Script_int.shift_right_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some r -> logged_return (Item (r, rest), ctxt) + end + | Or_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + | And_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | And_int_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | Xor_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + | Not_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + | Not_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + (* control *) + | Seq (hd, tl), stack -> + step_same ctxt hd stack >>=? fun (trans, ctxt) -> + step_same ctxt tl trans + | If (bt, _), Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt rest + | If (_, bf), Item (false, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf rest + | Loop body, Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step_same ctxt body rest >>=? fun (trans, ctxt) -> + step_same ctxt descr trans + | Loop _, Item (false, rest) -> + logged_return (rest, ctxt) + | Loop_left body, Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step_same ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> + step_same ctxt descr trans + | Loop_left _, Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + | Dip b, Item (ign, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + step_same ctxt b rest >>=? fun (res, ctxt) -> + logged_return (Item (ign, res), ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Lambda lam, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (lam, rest), ctxt) + | Failwith tv, Item (v, _) -> + trace Cannot_serialize_failure + (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (loc, v, get_log log)) + | Nop, stack -> + logged_return (stack, ctxt) + (* comparison *) + | Compare (Bool_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest + | Compare (String_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest + | Compare (Bytes_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest + | Compare (Mutez_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest + | Compare (Int_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest + | Compare (Nat_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest + | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Signature.Public_key_hash.compare + Interp_costs.compare_key_hash a b rest + | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest + | Compare (Address_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + (* packing *) + | Pack t, Item (value, rest) -> + Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> + logged_return (Item (bytes, rest), ctxt) + | Unpack t, Item (bytes, rest) -> + Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> + if Compare.Int.(MBytes.length bytes >= 1) && + Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Some expr -> + Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> + parse_data ctxt t (Micheline.root expr) >>= function + | Ok (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + | Error _ignored -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + else + logged_return (Item (None, rest), ctxt) + (* protocol *) + | Address, Item ((_, contract), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> + logged_return (Item (contract, rest), ctxt) + | Contract t, Item (contract, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> + Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) + | Transfer_tokens, + Item (p, Item (amount, Item ((tp, destination), rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> + unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> + let operation = + Transaction + { amount ; destination ; + parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + | Create_account, + Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; manager ; delegate ; preorigination = Some contract ; + delegatable ; script = None ; spendable = true } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, + Item (contract, rest)), ctxt) + | Implicit_account, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> + let contract = Contract.implicit_contract key in + logged_return (Item ((Unit_t None, contract), rest), ctxt) + | Create_contract (storage_type, param_type, Lam (_, code)), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (init, rest)))))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ Micheline.root code ], []) ])) in + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; manager ; delegate ; preorigination = Some contract ; + delegatable ; spendable ; + script = Some { code = Script.lazy_expr code ; + storage = Script.lazy_expr storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item (Internal_operation { source = self ; operation ; nonce }, + Item (contract, rest)), ctxt) + | Set_delegate, + Item (delegate, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + let operation = Delegation delegate in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + | Balance, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> + Contract.get_balance ctxt self >>=? fun balance -> + logged_return (Item (balance, rest), ctxt) + | Now, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), ctxt) + | Check_signature, Item (key, Item (signature, Item (message, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> + let res = Signature.check key signature message in + logged_return (Item (res, rest), ctxt) + | Hash_key, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + | Blake2b, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + let hash = Raw_hashes.blake2b bytes in + logged_return (Item (hash, rest), ctxt) + | Sha256, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + let hash = Raw_hashes.sha256 bytes in + logged_return (Item (hash, rest), ctxt) + | Sha512, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> + let hash = Raw_hashes.sha512 bytes in + logged_return (Item (hash, rest), ctxt) + | Steps_to_quota, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + let steps = match Gas.level ctxt with + | Limited { remaining } -> remaining + | Unaccounted -> Z.of_string "99999999" in + logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + | Source, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item (payer, rest), ctxt) + | Sender, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item (source, rest), ctxt) + | Self t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + logged_return (Item ((t,self), rest), ctxt) + | Amount, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + logged_return (Item (amount, rest), ctxt) + +and interp + : type p r. + (?log: execution_trace ref -> + context -> + source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> + (p, r) lambda -> p -> + (r * context) tzresult Lwt.t) + = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> + let stack = (Item (arg, Empty)) in + begin match log with + | None -> return_unit + | Some log -> + trace Cannot_serialize_log + (unparse_stack ctxt (stack, code.bef)) >>=? fun stack -> + log := (code.loc, Gas.level ctxt, stack) :: !log ; + return_unit + end >>=? fun () -> + step ctxt ~source ~payer ~self amount code stack >>=? fun (Item (ret, Empty), ctxt) -> + return (ret, ctxt) + + + +end + +open X_error_monad + let stack_ty_eq (type a b) ?(tezos_context = dummy_environment.tezos_context) (a:a stack_ty) (b:b stack_ty) = - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> + alpha_wrap (X.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> ok Eq let ty_eq (type a b) @@ -37,7 +962,7 @@ let parse_michelson (type aft) match j with | Typed descr -> ( Lwt.return ( - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> + alpha_wrap (X.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in Ok descr ) @@ -59,7 +984,7 @@ let parse_michelson_fail (type aft) match j with | Typed descr -> ( Lwt.return ( - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> + alpha_wrap (X.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in Ok descr ) @@ -87,7 +1012,7 @@ let parse_michelson_ty let unparse_michelson_data ?(tezos_context = dummy_environment.tezos_context) ?mapper ty value : Michelson.t tzresult Lwt.t = - Script_ir_translator.unparse_data tezos_context ?mapper + X.unparse_data_generic tezos_context ?mapper Readable ty value >>=?? fun (michelson, _) -> return michelson @@ -129,5 +1054,5 @@ let interpret ?(options = default_options) ?visitor (instr:('a, 'b) descr) (bef: payer ; amount ; } = options in - Script_interpreter.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=?? + X.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=?? fun (stack, _) -> return stack diff --git a/vendors/ligo-utils/simple-utils/simple-utils.opam b/vendors/ligo-utils/simple-utils/simple-utils.opam index ddb07c95e..abb4cf437 100644 --- a/vendors/ligo-utils/simple-utils/simple-utils.opam +++ b/vendors/ligo-utils/simple-utils/simple-utils.opam @@ -11,6 +11,7 @@ depends: [ "dune" "base" "yojson" + "ppx_let" # from ppx_let: "ocaml" {>= "4.04.2" & < "4.08.0"} "dune" {build & >= "1.5.1"} diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/.ocamlformat b/vendors/ligo-utils/tezos-protocol-alpha-parameters/.ocamlformat new file mode 100644 index 000000000..9d2a5a5f3 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/.ocamlformat @@ -0,0 +1,11 @@ +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml new file mode 100644 index 000000000..b9dcfcf39 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml @@ -0,0 +1,146 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +let constants_mainnet = + Constants_repr. + { + preserved_cycles = 5; + blocks_per_cycle = 4096l; + blocks_per_commitment = 32l; + blocks_per_roll_snapshot = 256l; + blocks_per_voting_period = 32768l; + time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 75L]; + endorsers_per_block = 32; + hard_gas_limit_per_operation = Z.of_int 800_000; + hard_gas_limit_per_block = Z.of_int 8_000_000; + proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L); + tokens_per_roll = Tez_repr.(mul_exn one 8_000); + michelson_maximum_type_size = 1000; + seed_nonce_revelation_tip = + (match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false); + origination_size = 257; + block_security_deposit = Tez_repr.(mul_exn one 512); + endorsement_security_deposit = Tez_repr.(mul_exn one 64); + block_reward = Tez_repr.(mul_exn one 16); + endorsement_reward = Tez_repr.(mul_exn one 2); + hard_storage_limit_per_operation = Z.of_int 60_000; + cost_per_byte = Tez_repr.of_mutez_exn 1_000L; + test_chain_duration = Int64.mul 32768L 60L; + } + +let constants_sandbox = + Constants_repr. + { + constants_mainnet with + preserved_cycles = 2; + blocks_per_cycle = 8l; + blocks_per_commitment = 4l; + blocks_per_roll_snapshot = 4l; + blocks_per_voting_period = 64l; + time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; + proof_of_work_threshold = Int64.of_int (-1); + } + +let constants_test = + Constants_repr. + { + constants_mainnet with + blocks_per_cycle = 128l; + blocks_per_commitment = 4l; + blocks_per_roll_snapshot = 32l; + blocks_per_voting_period = 256l; + time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; + proof_of_work_threshold = Int64.of_int (-1); + } + +let bootstrap_accounts_strings = + [ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"; + "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9"; + "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV"; + "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; + "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ] + +let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L + +let bootstrap_accounts = + List.map + (fun s -> + let public_key = Signature.Public_key.of_b58check_exn s in + let public_key_hash = Signature.Public_key.hash public_key in + Parameters_repr. + { + public_key_hash; + public_key = Some public_key; + amount = boostrap_balance; + }) + bootstrap_accounts_strings + +(* TODO this could be generated from OCaml together with the faucet + for now these are harcoded values in the tests *) +let commitments = + let json_result = + Data_encoding.Json.from_string + {json| + [ + [ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ], + [ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ], + [ "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428348" ], + [ "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ], + [ "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ], + [ "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ], + [ "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ], + [ "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ], + [ "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ], + [ "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ] + ]|json} + in + match json_result with + | Error err -> + raise (Failure err) + | Ok json -> + Data_encoding.Json.destruct + (Data_encoding.list Commitment_repr.encoding) + json + +let make_bootstrap_account (pkh, pk, amount) = + Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount} + +let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts) + ?(bootstrap_contracts = []) ?(with_commitments = false) constants = + let commitments = if with_commitments then commitments else [] in + Parameters_repr. + { + bootstrap_accounts; + bootstrap_contracts; + commitments; + constants; + security_deposit_ramp_up_cycles = None; + no_reward_cycles = None; + } + +let json_of_parameters parameters = + Data_encoding.Json.construct Parameters_repr.encoding parameters diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli new file mode 100644 index 000000000..598574c8f --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +val constants_mainnet : Constants_repr.parametric + +val constants_sandbox : Constants_repr.parametric + +val constants_test : Constants_repr.parametric + +val make_bootstrap_account : + Signature.public_key_hash * Signature.public_key * Tez_repr.t -> + Parameters_repr.bootstrap_account + +val parameters_of_constants : + ?bootstrap_accounts:Parameters_repr.bootstrap_account list -> + ?bootstrap_contracts:Parameters_repr.bootstrap_contract list -> + ?with_commitments:bool -> + Constants_repr.parametric -> + Parameters_repr.t + +val json_of_parameters : Parameters_repr.t -> Data_encoding.json diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune new file mode 100644 index 000000000..b2c277a02 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune @@ -0,0 +1,44 @@ +(library + (name tezos_protocol_alpha_parameters) + (public_name tezos-protocol-alpha-parameters) + (modules :standard \ gen) + (libraries tezos-base + tezos-protocol-environment + tezos-protocol-alpha) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_protocol_alpha + -linkall)) +) + +(executable + (name gen) + (libraries tezos-base + tezos-protocol-alpha-parameters) + (modules gen) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_protocol_alpha_parameters + -linkall))) + +(rule + (targets sandbox-parameters.json) + (deps gen.exe) + (action (run %{deps} --sandbox))) + +(rule + (targets test-parameters.json) + (deps gen.exe) + (action (run %{deps} --test))) + +(rule + (targets mainnet-parameters.json) + (deps gen.exe) + (action (run %{deps} --mainnet))) + +(install + (section lib) + (files sandbox-parameters.json test-parameters.json mainnet-parameters.json)) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project new file mode 100644 index 000000000..4afa89be6 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.10) +(name tezos-protocol-alpha-parameters) diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml b/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml new file mode 100644 index 000000000..93a0a459d --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Prints the json encoding of the parametric constants of protocol alpha. + $ dune utop src/proto_alpha/lib_protocol/test/helpers/ constants.ml +*) + +let () = + let print_usage_and_fail s = + Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ; + raise (Invalid_argument s) + in + let dump parameters file = + let str = + Data_encoding.Json.to_string + (Default_parameters.json_of_parameters parameters) + in + let fd = open_out file in + output_string fd str ; close_out fd + in + if Array.length Sys.argv < 2 then print_usage_and_fail "" + else + match Sys.argv.(1) with + | "--sandbox" -> + dump + Default_parameters.(parameters_of_constants constants_sandbox) + "sandbox-parameters.json" + | "--test" -> + dump + Default_parameters.( + parameters_of_constants ~with_commitments:true constants_sandbox) + "test-parameters.json" + | "--mainnet" -> + dump + Default_parameters.( + parameters_of_constants ~with_commitments:true constants_mainnet) + "mainnet-parameters.json" + | s -> + print_usage_and_fail s diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam b/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam new file mode 100644 index 000000000..481bde015 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam @@ -0,0 +1,21 @@ +opam-version: "2.0" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "ocamlfind" { build } + "dune" { build & >= "1.7" } + "tezos-base" + "tezos-protocol-environment" + "tezos-protocol-alpha" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: parameters" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat b/vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat new file mode 100644 index 000000000..9d2a5a5f3 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat @@ -0,0 +1,11 @@ +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat-ignore b/vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat-ignore new file mode 100644 index 000000000..638f36536 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat-ignore @@ -0,0 +1,120 @@ +alpha_context.ml +alpha_context.mli +alpha_services.ml +alpha_services.mli +amendment.ml +amendment.mli +apply.ml +apply_results.ml +apply_results.mli +baking.ml +baking.mli +blinded_public_key_hash.ml +blinded_public_key_hash.mli +block_header_repr.ml +block_header_repr.mli +bootstrap_storage.ml +bootstrap_storage.mli +commitment_repr.ml +commitment_repr.mli +commitment_storage.ml +commitment_storage.mli +constants_repr.ml +constants_services.ml +constants_services.mli +constants_storage.ml +contract_hash.ml +contract_repr.ml +contract_repr.mli +contract_services.ml +contract_services.mli +contract_storage.ml +contract_storage.mli +cycle_repr.ml +cycle_repr.mli +delegate_services.ml +delegate_services.mli +delegate_storage.ml +delegate_storage.mli +fees_storage.ml +fees_storage.mli +fitness_repr.ml +fitness_storage.ml +gas_limit_repr.ml +gas_limit_repr.mli +helpers_services.ml +helpers_services.mli +init_storage.ml +level_repr.ml +level_repr.mli +level_storage.ml +level_storage.mli +main.ml +main.mli +manager_repr.ml +manager_repr.mli +michelson_v1_gas.ml +michelson_v1_gas.mli +michelson_v1_primitives.ml +michelson_v1_primitives.mli +misc.ml +misc.mli +nonce_hash.ml +nonce_storage.ml +nonce_storage.mli +operation_repr.ml +operation_repr.mli +parameters_repr.ml +parameters_repr.mli +period_repr.ml +period_repr.mli +qty_repr.ml +raw_context.ml +raw_context.mli +raw_level_repr.ml +raw_level_repr.mli +roll_repr.ml +roll_repr.mli +roll_storage.ml +roll_storage.mli +script_expr_hash.ml +script_interpreter.ml +script_interpreter.mli +script_int_repr.ml +script_int_repr.mli +script_ir_annot.ml +script_ir_annot.mli +script_ir_translator.ml +script_ir_translator.mli +script_repr.ml +script_repr.mli +script_tc_errors.ml +script_tc_errors_registration.ml +script_timestamp_repr.ml +script_timestamp_repr.mli +script_typed_ir.ml +seed_repr.ml +seed_repr.mli +seed_storage.ml +seed_storage.mli +services_registration.ml +state_hash.ml +storage_description.ml +storage_description.mli +storage_functors.ml +storage_functors.mli +storage.ml +storage.mli +storage_sigs.ml +tez_repr.ml +tez_repr.mli +time_repr.ml +time_repr.mli +vote_repr.ml +vote_repr.mli +vote_storage.ml +vote_storage.mli +voting_period_repr.ml +voting_period_repr.mli +voting_services.ml +voting_services.mli diff --git a/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL b/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL new file mode 100644 index 000000000..227ece362 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL @@ -0,0 +1,81 @@ +{ + "hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK", + "modules": [ + "Misc", + "Storage_description", + "State_hash", + "Nonce_hash", + "Script_expr_hash", + "Contract_hash", + "Blinded_public_key_hash", + + "Qty_repr", + "Tez_repr", + "Period_repr", + "Time_repr", + "Constants_repr", + "Fitness_repr", + "Raw_level_repr", + "Voting_period_repr", + "Cycle_repr", + "Level_repr", + "Seed_repr", + "Gas_limit_repr", + "Script_int_repr", + "Script_timestamp_repr", + "Michelson_v1_primitives", + "Script_repr", + "Contract_repr", + "Roll_repr", + "Vote_repr", + "Block_header_repr", + "Operation_repr", + "Manager_repr", + "Commitment_repr", + "Parameters_repr", + + "Raw_context", + "Storage_sigs", + "Storage_functors", + "Storage", + + "Constants_storage", + "Level_storage", + "Nonce_storage", + "Seed_storage", + "Roll_storage", + "Delegate_storage", + "Contract_storage", + "Bootstrap_storage", + "Fitness_storage", + "Vote_storage", + "Commitment_storage", + "Init_storage", + "Fees_storage", + + "Alpha_context", + + "Script_typed_ir", + "Script_tc_errors", + "Michelson_v1_gas", + "Script_ir_annot", + "Script_ir_translator", + "Script_tc_errors_registration", + "Script_interpreter", + + "Baking", + "Amendment", + "Apply_results", + "Apply", + + "Services_registration", + "Constants_services", + "Contract_services", + "Delegate_services", + "Helpers_services", + "Voting_services", + "Alpha_services", + + "Main" + ] +} diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml new file mode 100644 index 000000000..435d9920e --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml @@ -0,0 +1,186 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Raw_context.t +type context = t + +module type BASIC_DATA = sig + type t + include Compare.S with type t := t + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit +end + +module Tez = Tez_repr +module Period = Period_repr + +module Timestamp = struct + include Time_repr + let current = Raw_context.current_timestamp +end + +include Operation_repr +module Operation = struct + type 'kind t = 'kind operation = { + shell: Operation.shell_header ; + protocol_data: 'kind protocol_data ; + } + type packed = packed_operation + let unsigned_encoding = unsigned_operation_encoding + include Operation_repr +end +module Block_header = Block_header_repr +module Vote = struct + include Vote_repr + include Vote_storage +end +module Raw_level = Raw_level_repr +module Cycle = Cycle_repr +module Script_int = Script_int_repr +module Script_timestamp = struct + include Script_timestamp_repr + let now ctxt = + Raw_context.current_timestamp ctxt + |> Timestamp.to_seconds + |> of_int64 +end +module Script = struct + include Michelson_v1_primitives + include Script_repr + let force_decode ctxt lexpr = + Lwt.return + (Script_repr.force_decode lexpr >>? fun (v, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> + (v, ctxt)) + let force_bytes ctxt lexpr = + Lwt.return + (Script_repr.force_bytes lexpr >>? fun (b, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> + (b, ctxt)) +end +module Fees = Fees_storage + +type public_key = Signature.Public_key.t +type public_key_hash = Signature.Public_key_hash.t +type signature = Signature.t + +module Constants = struct + include Constants_repr + include Constants_storage +end + +module Voting_period = Voting_period_repr + +module Gas = struct + include Gas_limit_repr + type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high + let check_limit = Raw_context.check_gas_limit + let set_limit = Raw_context.set_gas_limit + let set_unlimited = Raw_context.set_gas_unlimited + let consume = Raw_context.consume_gas + let check_enough = Raw_context.check_enough_gas + let level = Raw_context.gas_level + let consumed = Raw_context.gas_consumed + let block_level = Raw_context.block_gas_level +end +module Level = struct + include Level_repr + include Level_storage +end +module Contract = struct + include Contract_repr + include Contract_storage + + let originate c contract ~balance ~manager ?script ~delegate + ~spendable ~delegatable = + originate c contract ~balance ~manager ?script ~delegate + ~spendable ~delegatable + let init_origination_nonce = Raw_context.init_origination_nonce + let unset_origination_nonce = Raw_context.unset_origination_nonce +end +module Delegate = Delegate_storage +module Roll = struct + include Roll_repr + include Roll_storage +end +module Nonce = Nonce_storage +module Seed = struct + include Seed_repr + include Seed_storage +end + +module Fitness = struct + + include Fitness_repr + include Fitness + type fitness = t + include Fitness_storage + +end + +module Bootstrap = Bootstrap_storage + +module Commitment = struct + include Commitment_repr + include Commitment_storage +end + +module Global = struct + let get_last_block_priority = Storage.Last_block_priority.get + let set_last_block_priority = Storage.Last_block_priority.set +end + +let prepare_first_block = Init_storage.prepare_first_block +let prepare = Init_storage.prepare + +let finalize ?commit_message:message c = + let fitness = Fitness.from_int64 (Fitness.current c) in + let context = Raw_context.recover c in + { Updater.context ; fitness ; message ; max_operations_ttl = 60 ; + last_allowed_fork_level = + Raw_level.to_int32 @@ Level.last_allowed_fork_level c; + } + +let activate = Raw_context.activate +let fork_test_chain = Raw_context.fork_test_chain + +let record_endorsement = Raw_context.record_endorsement +let allowed_endorsements = Raw_context.allowed_endorsements +let init_endorsements = Raw_context.init_endorsements + +let reset_internal_nonce = Raw_context.reset_internal_nonce +let fresh_internal_nonce = Raw_context.fresh_internal_nonce +let record_internal_nonce = Raw_context.record_internal_nonce +let internal_nonce_already_recorded = Raw_context.internal_nonce_already_recorded + +let add_deposit = Raw_context.add_deposit +let add_fees = Raw_context.add_fees +let add_rewards = Raw_context.add_rewards + +let get_deposits = Raw_context.get_deposits +let get_fees = Raw_context.get_fees +let get_rewards = Raw_context.get_rewards + +let description = Raw_context.description diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli new file mode 100644 index 000000000..62d317621 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli @@ -0,0 +1,1164 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type BASIC_DATA = sig + type t + include Compare.S with type t := t + val encoding: t Data_encoding.t + val pp: Format.formatter -> t -> unit +end + +type t +type context = t + +type public_key = Signature.Public_key.t +type public_key_hash = Signature.Public_key_hash.t +type signature = Signature.t + +module Tez : sig + + include BASIC_DATA + type tez = t + + val zero: tez + val one_mutez: tez + val one_cent: tez + val fifty_cents: tez + val one: tez + + val ( -? ) : tez -> tez -> tez tzresult + val ( +? ) : tez -> tez -> tez tzresult + val ( *? ) : tez -> int64 -> tez tzresult + val ( /? ) : tez -> int64 -> tez tzresult + + val of_string: string -> tez option + val to_string: tez -> string + + val of_mutez: int64 -> tez option + val to_mutez: tez -> int64 + +end + +module Period : sig + + include BASIC_DATA + type period = t + + val of_seconds: int64 -> period tzresult + val to_seconds: period -> int64 + val mult: int32 -> period -> period tzresult + + val one_second: period + val one_minute: period + val one_hour: period + +end + +module Timestamp : sig + + include BASIC_DATA with type t = Time.t + type time = t + val (+?) : time -> Period.t -> time tzresult + + val of_notation: string -> time option + val to_notation: time -> string + + val of_seconds: string -> time option + val to_seconds_string: time -> string + + val current: context -> time + +end + +module Raw_level : sig + + include BASIC_DATA + type raw_level = t + val rpc_arg: raw_level RPC_arg.arg + + val diff: raw_level -> raw_level -> int32 + + val root: raw_level + val succ: raw_level -> raw_level + val pred: raw_level -> raw_level option + val to_int32: raw_level -> int32 + val of_int32: int32 -> raw_level tzresult + +end + +module Cycle : sig + + include BASIC_DATA + type cycle = t + val rpc_arg: cycle RPC_arg.arg + + val root: cycle + val succ: cycle -> cycle + val pred: cycle -> cycle option + val add: cycle -> int -> cycle + val sub: cycle -> int -> cycle option + val to_int32: cycle -> int32 + + module Map : S.MAP with type key = cycle + +end + +module Gas : sig + type t = private + | Unaccounted + | Limited of { remaining : Z.t } + + val encoding : t Data_encoding.encoding + val pp : Format.formatter -> t -> unit + + type cost + + val cost_encoding : cost Data_encoding.encoding + val pp_cost : Format.formatter -> cost -> unit + + type error += Block_quota_exceeded (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) + type error += Gas_limit_too_high (* `Permanent *) + + val free : cost + val step_cost : int -> cost + val alloc_cost : int -> cost + val alloc_bytes_cost : int -> cost + val alloc_mbytes_cost : int -> cost + val alloc_bits_cost : int -> cost + val read_bytes_cost : Z.t -> cost + val write_bytes_cost : Z.t -> cost + + val ( *@ ) : int -> cost -> cost + val ( +@ ) : cost -> cost -> cost + + val check_limit: context -> Z.t -> unit tzresult + val set_limit: context -> Z.t -> context + val set_unlimited: context -> context + val consume: context -> cost -> context tzresult + val check_enough: context -> cost -> unit tzresult + val level: context -> t + val consumed: since: context -> until: context -> Z.t + val block_level: context -> Z.t +end + +module Script_int : module type of Script_int_repr + +module Script_timestamp : sig + open Script_int + type t + val compare: t -> t -> int + val to_string: t -> string + val to_notation: t -> string option + val to_num_str: t -> string + val of_string: string -> t option + val diff: t -> t -> z num + val add_delta: t -> z num -> t + val sub_delta: t -> z num -> t + val now: context -> t + val to_zint: t -> Z.t + val of_zint: Z.t -> t +end + +module Script : sig + + type prim = Michelson_v1_primitives.prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + + type location = Micheline.canonical_location + + type annot = Micheline.annot + + type expr = prim Micheline.canonical + + type lazy_expr = expr Data_encoding.lazy_t + + val lazy_expr : expr -> lazy_expr + + type node = (location, prim) Micheline.node + + type t = + { code: lazy_expr ; + storage: lazy_expr } + + val location_encoding: location Data_encoding.t + val expr_encoding: expr Data_encoding.t + val prim_encoding: prim Data_encoding.t + val encoding: t Data_encoding.t + val lazy_expr_encoding: lazy_expr Data_encoding.t + val deserialized_cost : expr -> Gas.cost + val serialized_cost : MBytes.t -> Gas.cost + val traversal_cost : node -> Gas.cost + val node_cost : node -> Gas.cost + val int_node_cost : Z.t -> Gas.cost + val int_node_cost_of_numbits : int -> Gas.cost + val string_node_cost : string -> Gas.cost + val string_node_cost_of_length : int -> Gas.cost + val bytes_node_cost : MBytes.t -> Gas.cost + val bytes_node_cost_of_length : int -> Gas.cost + val prim_node_cost_nonrec : expr list -> annot -> Gas.cost + val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost + val seq_node_cost_nonrec : expr list -> Gas.cost + val seq_node_cost_nonrec_of_length : int -> Gas.cost + val minimal_deserialize_cost : lazy_expr -> Gas.cost + val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t + val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t +end + +module Constants : sig + + (** Fixed constants *) + type fixed = { + proof_of_work_nonce_size : int ; + nonce_length : int ; + max_revelations_per_block : int ; + max_operation_data_length : int ; + max_proposals_per_delegate : int ; + } + val fixed_encoding: fixed Data_encoding.t + val fixed: fixed + + val proof_of_work_nonce_size: int + val nonce_length: int + val max_revelations_per_block: int + val max_operation_data_length: int + val max_proposals_per_delegate: int + + (** Constants parameterized by context *) + type parametric = { + preserved_cycles: int ; + blocks_per_cycle: int32 ; + blocks_per_commitment: int32 ; + blocks_per_roll_snapshot: int32 ; + blocks_per_voting_period: int32 ; + time_between_blocks: Period.t list ; + endorsers_per_block: int ; + hard_gas_limit_per_operation: Z.t ; + hard_gas_limit_per_block: Z.t ; + proof_of_work_threshold: int64 ; + tokens_per_roll: Tez.t ; + michelson_maximum_type_size: int; + seed_nonce_revelation_tip: Tez.t ; + origination_size: int ; + block_security_deposit: Tez.t ; + endorsement_security_deposit: Tez.t ; + block_reward: Tez.t ; + endorsement_reward: Tez.t ; + cost_per_byte: Tez.t ; + hard_storage_limit_per_operation: Z.t ; + test_chain_duration: int64; + } + val parametric_encoding: parametric Data_encoding.t + val parametric: context -> parametric + val preserved_cycles: context -> int + val blocks_per_cycle: context -> int32 + val blocks_per_commitment: context -> int32 + val blocks_per_roll_snapshot: context -> int32 + val blocks_per_voting_period: context -> int32 + val time_between_blocks: context -> Period.t list + val endorsers_per_block: context -> int + val hard_gas_limit_per_operation: context -> Z.t + val hard_gas_limit_per_block: context -> Z.t + val cost_per_byte: context -> Tez.t + val hard_storage_limit_per_operation: context -> Z.t + val proof_of_work_threshold: context -> int64 + val tokens_per_roll: context -> Tez.t + val michelson_maximum_type_size: context -> int + val block_reward: context -> Tez.t + val endorsement_reward: context -> Tez.t + val seed_nonce_revelation_tip: context -> Tez.t + val origination_size: context -> int + val block_security_deposit: context -> Tez.t + val endorsement_security_deposit: context -> Tez.t + val test_chain_duration: context -> int64 + + (** All constants: fixed and parametric *) + type t = { + fixed : fixed ; + parametric : parametric ; + } + val encoding: t Data_encoding.t + +end + +module Voting_period : sig + + include BASIC_DATA + type voting_period = t + val rpc_arg: voting_period RPC_arg.arg + + val root: voting_period + val succ: voting_period -> voting_period + + type kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + val kind_encoding: kind Data_encoding.encoding + val to_int32: voting_period -> int32 + +end + +module Level : sig + + type t = private { + level: Raw_level.t ; + level_position: int32 ; + cycle: Cycle.t ; + cycle_position: int32 ; + voting_period: Voting_period.t ; + voting_period_position: int32 ; + expected_commitment: bool ; + } + include BASIC_DATA with type t := t + val pp_full: Format.formatter -> t -> unit + type level = t + + val root: context -> level + + val succ: context -> level -> level + val pred: context -> level -> level option + + val from_raw: context -> ?offset:int32 -> Raw_level.t -> level + + val diff: level -> level -> int32 + + val current: context -> level + + val last_level_in_cycle: context -> Cycle.t -> level + val levels_in_cycle: context -> Cycle.t -> level list + val levels_in_current_cycle: context -> ?offset:int32 -> unit -> level list + + val last_allowed_fork_level: context -> Raw_level.t + +end + +module Fitness : sig + + include (module type of Fitness) + type fitness = t + + val increase: ?gap:int -> context -> context + + val current: context -> int64 + + val to_int64: fitness -> int64 tzresult + +end + +module Nonce : sig + + type t + type nonce = t + val encoding: nonce Data_encoding.t + + type unrevealed = { + nonce_hash: Nonce_hash.t ; + delegate: public_key_hash ; + rewards: Tez.t ; + fees: Tez.t ; + } + + val record_hash: + context -> unrevealed -> context tzresult Lwt.t + + val reveal: + context -> Level.t -> nonce -> + context tzresult Lwt.t + + type status = + | Unrevealed of unrevealed + | Revealed of nonce + + val get: context -> Level.t -> status tzresult Lwt.t + + val of_bytes: MBytes.t -> nonce tzresult + val hash: nonce -> Nonce_hash.t + val check_hash: nonce -> Nonce_hash.t -> bool + +end + +module Seed : sig + + type seed + + type error += + | Unknown of { oldest : Cycle.t ; + cycle : Cycle.t ; + latest : Cycle.t } + + val for_cycle: + context -> Cycle.t -> seed tzresult Lwt.t + + val cycle_end: + context -> Cycle.t -> (context * Nonce.unrevealed list) tzresult Lwt.t + + val seed_encoding : seed Data_encoding.t + +end + +module Contract : sig + + include BASIC_DATA + type contract = t + val rpc_arg: contract RPC_arg.arg + + val to_b58check: contract -> string + val of_b58check: string -> contract tzresult + + val implicit_contract: public_key_hash -> contract + val is_implicit: contract -> public_key_hash option + + val exists: context -> contract -> bool tzresult Lwt.t + val must_exist: context -> contract -> unit tzresult Lwt.t + + val allocated: context -> contract -> bool tzresult Lwt.t + val must_be_allocated: context -> contract -> unit tzresult Lwt.t + + val list: context -> contract list Lwt.t + + val get_manager: + context -> contract -> public_key_hash tzresult Lwt.t + + val get_manager_key: + context -> contract -> public_key tzresult Lwt.t + val is_manager_key_revealed: + context -> contract -> bool tzresult Lwt.t + + val reveal_manager_key: + context -> contract -> public_key -> context tzresult Lwt.t + + val is_delegatable: + context -> contract -> bool tzresult Lwt.t + val is_spendable: + context -> contract -> bool tzresult Lwt.t + val get_script: + context -> contract -> (context * Script.t option) tzresult Lwt.t + val get_storage: + context -> contract -> (context * Script.expr option) tzresult Lwt.t + + val get_counter: context -> contract -> Z.t tzresult Lwt.t + val get_balance: + context -> contract -> Tez.t tzresult Lwt.t + + val init_origination_nonce: context -> Operation_hash.t -> context + val unset_origination_nonce: context -> context + val fresh_contract_from_current_nonce : context -> (context * t) tzresult Lwt.t + val originated_from_current_nonce: since: context -> until:context -> contract list tzresult Lwt.t + + type big_map_diff_item = { + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + type big_map_diff = big_map_diff_item list + val big_map_diff_encoding : big_map_diff Data_encoding.t + + val originate: + context -> contract -> + balance: Tez.t -> + manager: public_key_hash -> + ?script: (Script.t * big_map_diff option) -> + delegate: public_key_hash option -> + spendable: bool -> + delegatable: bool -> context tzresult Lwt.t + + type error += Balance_too_low of contract * Tez.t * Tez.t + + val spend: + context -> contract -> Tez.t -> context tzresult Lwt.t + val spend_from_script: + context -> contract -> Tez.t -> context tzresult Lwt.t + + val credit: + context -> contract -> Tez.t -> context tzresult Lwt.t + + val update_script_storage: + context -> contract -> + Script.expr -> big_map_diff option -> + context tzresult Lwt.t + + val used_storage_space: context -> t -> Z.t tzresult Lwt.t + + val increment_counter: + context -> contract -> context tzresult Lwt.t + + val check_counter_increment: + context -> contract -> Z.t -> unit tzresult Lwt.t + + module Big_map : sig + val mem: + context -> contract -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t + val get_opt: + context -> contract -> Script_expr_hash.t -> (context * Script_repr.expr option) tzresult Lwt.t + end + + (**/**) + (* Only for testing *) + type origination_nonce + val initial_origination_nonce : Operation_hash.t -> origination_nonce + val originated_contract : origination_nonce -> contract + +end + +module Delegate : sig + + type balance = + | Contract of Contract.t + | Rewards of Signature.Public_key_hash.t * Cycle.t + | Fees of Signature.Public_key_hash.t * Cycle.t + | Deposits of Signature.Public_key_hash.t * Cycle.t + + type balance_update = + | Debited of Tez.t + | Credited of Tez.t + + type balance_updates = (balance * balance_update) list + + val balance_updates_encoding : balance_updates Data_encoding.t + + val cleanup_balance_updates : balance_updates -> balance_updates + + val get: context -> Contract.t -> public_key_hash option tzresult Lwt.t + + val set: + context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t + + val set_from_script: + context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t + + val fold: + context -> + init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val list: context -> public_key_hash list Lwt.t + + val freeze_deposit: + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val freeze_rewards: + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val freeze_fees: + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val cycle_end: + context -> Cycle.t -> Nonce.unrevealed list -> + (context * balance_updates * Signature.Public_key_hash.t list) tzresult Lwt.t + + type frozen_balance = { + deposit : Tez.t ; + fees : Tez.t ; + rewards : Tez.t ; + } + + val punish: + context -> public_key_hash -> Cycle.t -> + (context * frozen_balance) tzresult Lwt.t + + val full_balance: + context -> public_key_hash -> Tez.t tzresult Lwt.t + + val has_frozen_balance: + context -> public_key_hash -> Cycle.t -> + bool tzresult Lwt.t + + val frozen_balance: + context -> public_key_hash -> Tez.t tzresult Lwt.t + + val frozen_balance_encoding: frozen_balance Data_encoding.t + val frozen_balance_by_cycle_encoding: frozen_balance Cycle.Map.t Data_encoding.t + + val frozen_balance_by_cycle: + context -> Signature.Public_key_hash.t -> + frozen_balance Cycle.Map.t Lwt.t + + val staking_balance: + context -> Signature.Public_key_hash.t -> + Tez.t tzresult Lwt.t + + val delegated_contracts: + context -> Signature.Public_key_hash.t -> + Contract_hash.t list Lwt.t + + val delegated_balance: + context -> Signature.Public_key_hash.t -> + Tez.t tzresult Lwt.t + + val deactivated: + context -> Signature.Public_key_hash.t -> + bool tzresult Lwt.t + + val grace_period: + context -> Signature.Public_key_hash.t -> + Cycle.t tzresult Lwt.t + +end + +module Vote : sig + + type proposal = Protocol_hash.t + + val record_proposal: + context -> Protocol_hash.t -> public_key_hash -> + context tzresult Lwt.t + val get_proposals: + context -> int32 Protocol_hash.Map.t tzresult Lwt.t + val clear_proposals: context -> context Lwt.t + + val recorded_proposal_count_for_delegate: + context -> public_key_hash -> int tzresult Lwt.t + + val listings_encoding : (Signature.Public_key_hash.t * int32) list Data_encoding.t + val freeze_listings: context -> context tzresult Lwt.t + val clear_listings: context -> context tzresult Lwt.t + val listing_size: context -> int32 tzresult Lwt.t + val in_listings: context -> public_key_hash -> bool Lwt.t + val get_listings : context -> (public_key_hash * int32) list Lwt.t + + type ballot = Yay | Nay | Pass + val ballot_encoding : ballot Data_encoding.t + + type ballots = { + yay: int32 ; + nay: int32 ; + pass: int32 ; + } + + val ballots_encoding : ballots Data_encoding.t + + val has_recorded_ballot : + context -> public_key_hash -> bool Lwt.t + val record_ballot: + context -> public_key_hash -> ballot -> context tzresult Lwt.t + val get_ballots: context -> ballots tzresult Lwt.t + val get_ballot_list: context -> (Signature.Public_key_hash.t * ballot) list Lwt.t + val clear_ballots: context -> context Lwt.t + + val get_current_period_kind: + context -> Voting_period.kind tzresult Lwt.t + val set_current_period_kind: + context -> Voting_period.kind -> context tzresult Lwt.t + + val get_current_quorum: context -> int32 tzresult Lwt.t + val set_current_quorum: context -> int32 -> context tzresult Lwt.t + + val get_current_proposal: + context -> proposal tzresult Lwt.t + val init_current_proposal: + context -> proposal -> context tzresult Lwt.t + val clear_current_proposal: + context -> context tzresult Lwt.t + +end + +module Block_header : sig + + type t = { + shell: Block_header.shell_header ; + protocol_data: protocol_data ; + } + + and protocol_data = { + contents: contents ; + signature: Signature.t ; + } + + and contents = { + priority: int ; + seed_nonce_hash: Nonce_hash.t option ; + proof_of_work_nonce: MBytes.t ; + } + + type block_header = t + + type raw = Block_header.t + type shell_header = Block_header.shell_header + + val raw: block_header -> raw + + val hash: block_header -> Block_hash.t + val hash_raw: raw -> Block_hash.t + + val encoding: block_header Data_encoding.encoding + val raw_encoding: raw Data_encoding.t + val contents_encoding: contents Data_encoding.t + val unsigned_encoding: (shell_header * contents) Data_encoding.t + val protocol_data_encoding: protocol_data Data_encoding.encoding + val shell_header_encoding: shell_header Data_encoding.encoding + + val max_header_length: int + (** The maximum size of block headers in bytes *) + +end + +module Kind : sig + type seed_nonce_revelation = Seed_nonce_revelation_kind + type double_endorsement_evidence = Double_endorsement_evidence_kind + type double_baking_evidence = Double_baking_evidence_kind + type activate_account = Activate_account_kind + type endorsement = Endorsement_kind + type proposals = Proposals_kind + type ballot = Ballot_kind + type reveal = Reveal_kind + type transaction = Transaction_kind + type origination = Origination_kind + type delegation = Delegation_kind + type 'a manager = + | Reveal_manager_kind : reveal manager + | Transaction_manager_kind : transaction manager + | Origination_manager_kind : origination manager + | Delegation_manager_kind : delegation manager +end + +type 'kind operation = { + shell: Operation.shell_header ; + protocol_data: 'kind protocol_data ; +} + +and 'kind protocol_data = { + contents: 'kind contents_list ; + signature: Signature.t option ; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : 'kind Kind.manager contents * 'rest Kind.manager contents_list -> + (('kind * 'rest) Kind.manager ) contents_list + +and _ contents = + | Endorsement : { + level: Raw_level.t ; + } -> Kind.endorsement contents + | Seed_nonce_revelation : { + level: Raw_level.t ; + nonce: Nonce.t ; + } -> Kind.seed_nonce_revelation contents + | Double_endorsement_evidence : { + op1: Kind.endorsement operation ; + op2: Kind.endorsement operation ; + } -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1: Block_header.t ; + bh2: Block_header.t ; + } -> Kind.double_baking_evidence contents + | Activate_account : { + id: Ed25519.Public_key_hash.t ; + activation_code: Blinded_public_key_hash.activation_code ; + } -> Kind.activate_account contents + | Proposals : { + source: Signature.Public_key_hash.t ; + period: Voting_period.t ; + proposals: Protocol_hash.t list ; + } -> Kind.proposals contents + | Ballot : { + source: Signature.Public_key_hash.t ; + period: Voting_period.t ; + proposal: Protocol_hash.t ; + ballot: Vote.ballot ; + } -> Kind.ballot contents + | Manager_operation : { + source: Contract.contract ; + fee: Tez.tez ; + counter: counter ; + operation: 'kind manager_operation ; + gas_limit: Z.t; + storage_limit: Z.t; + } -> 'kind Kind.manager contents + +and _ manager_operation = + | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation + | Transaction : { + amount: Tez.tez ; + parameters: Script.lazy_expr option ; + destination: Contract.contract ; + } -> Kind.transaction manager_operation + | Origination : { + manager: Signature.Public_key_hash.t ; + delegate: Signature.Public_key_hash.t option ; + script: Script.t option ; + spendable: bool ; + delegatable: bool ; + credit: Tez.tez ; + preorigination: Contract.t option ; + } -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option -> Kind.delegation manager_operation + +and counter = Z.t + +type 'kind internal_operation = { + source: Contract.contract ; + operation: 'kind manager_operation ; + nonce: int ; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +type packed_contents = + | Contents : 'kind contents -> packed_contents + +type packed_contents_list = + | Contents_list : 'kind contents_list -> packed_contents_list + +type packed_protocol_data = + | Operation_data : 'kind protocol_data -> packed_protocol_data + +type packed_operation = { + shell: Operation.shell_header ; + protocol_data: packed_protocol_data ; +} + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +val manager_kind: 'kind manager_operation -> 'kind Kind.manager + +module Fees : sig + + val origination_burn: + context -> (context * Tez.t) tzresult Lwt.t + + val record_paid_storage_space: + context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t + + val start_counting_storage_fees : + context -> context + + val burn_storage_fees: + context -> storage_limit:Z.t -> payer:Contract.t -> context tzresult Lwt.t + + type error += Cannot_pay_storage_fee (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) + type error += Storage_limit_too_high (* `Permanent *) + + val check_storage_limit: context -> storage_limit:Z.t -> unit tzresult + +end + +module Operation : sig + + type nonrec 'kind contents = 'kind contents + type nonrec packed_contents = packed_contents + val contents_encoding: packed_contents Data_encoding.t + + type nonrec 'kind protocol_data = 'kind protocol_data + type nonrec packed_protocol_data = packed_protocol_data + val protocol_data_encoding: packed_protocol_data Data_encoding.t + val unsigned_encoding: (Operation.shell_header * packed_contents_list) Data_encoding.t + + type raw = Operation.t = { + shell: Operation.shell_header ; + proto: MBytes.t ; + } + val raw_encoding: raw Data_encoding.t + val contents_list_encoding: packed_contents_list Data_encoding.t + + type 'kind t = 'kind operation = { + shell: Operation.shell_header ; + protocol_data: 'kind protocol_data ; + } + type nonrec packed = packed_operation + val encoding: packed Data_encoding.t + + val raw: _ operation -> raw + + val hash: _ operation -> Operation_hash.t + val hash_raw: raw -> Operation_hash.t + val hash_packed: packed_operation -> Operation_hash.t + + val acceptable_passes: packed_operation -> int list + + type error += Missing_signature (* `Permanent *) + type error += Invalid_signature (* `Permanent *) + + val check_signature: public_key -> Chain_id.t -> _ operation -> unit tzresult Lwt.t + val check_signature_sync: public_key -> Chain_id.t -> _ operation -> unit tzresult + + val internal_operation_encoding: packed_internal_operation Data_encoding.t + + val pack: 'kind operation -> packed_operation + + type ('a, 'b) eq = Eq : ('a, 'a) eq + val equal: 'a operation -> 'b operation -> ('a, 'b) eq option + + module Encoding : sig + + type 'b case = + Case : { tag: int ; + name: string ; + encoding: 'a Data_encoding.t ; + select: packed_contents -> 'b contents option ; + proj: 'b contents -> 'a ; + inj: 'a -> 'b contents } -> 'b case + + val endorsement_case: Kind.endorsement case + val seed_nonce_revelation_case: Kind.seed_nonce_revelation case + val double_endorsement_evidence_case: Kind.double_endorsement_evidence case + val double_baking_evidence_case: Kind.double_baking_evidence case + val activate_account_case: Kind.activate_account case + val proposals_case: Kind.proposals case + val ballot_case: Kind.ballot case + val reveal_case: Kind.reveal Kind.manager case + val transaction_case: Kind.transaction Kind.manager case + val origination_case: Kind.origination Kind.manager case + val delegation_case: Kind.delegation Kind.manager case + + module Manager_operations : sig + + type 'b case = + MCase : { tag: int ; + name: string ; + encoding: 'a Data_encoding.t ; + select: packed_manager_operation -> 'kind manager_operation option ; + proj: 'kind manager_operation -> 'a ; + inj: 'a -> 'kind manager_operation } -> 'kind case + + val reveal_case: Kind.reveal case + val transaction_case: Kind.transaction case + val origination_case: Kind.origination case + val delegation_case: Kind.delegation case + + end + + end + + val of_list: packed_contents list -> packed_contents_list + val to_list: packed_contents_list -> packed_contents list + +end + +module Roll : sig + + type t = private int32 + type roll = t + + val encoding: roll Data_encoding.t + + val snapshot_rolls: context -> context tzresult Lwt.t + val cycle_end: context -> Cycle.t -> context tzresult Lwt.t + + val baking_rights_owner: + context -> Level.t -> priority:int -> public_key tzresult Lwt.t + + val endorsement_rights_owner: + context -> Level.t -> slot:int -> public_key tzresult Lwt.t + + val delegate_pubkey: + context -> public_key_hash -> public_key tzresult Lwt.t + + val get_rolls: + context -> Signature.Public_key_hash.t -> roll list tzresult Lwt.t + val get_change: + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t + +end + +module Commitment : sig + + type t = + { blinded_public_key_hash : Blinded_public_key_hash.t ; + amount : Tez.tez } + + val get_opt: + context -> Blinded_public_key_hash.t -> Tez.t option tzresult Lwt.t + val delete: + context -> Blinded_public_key_hash.t -> context tzresult Lwt.t + +end + +module Bootstrap : sig + + val cycle_end: + context -> Cycle.t -> context tzresult Lwt.t + +end + +module Global : sig + + val get_last_block_priority: context -> int tzresult Lwt.t + val set_last_block_priority: context -> int -> context tzresult Lwt.t + +end + +val prepare_first_block: + Context.t -> + typecheck:(context -> Script.t -> + ((Script.t * Contract.big_map_diff option) * context) tzresult Lwt.t) -> + level:Int32.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + context tzresult Lwt.t + +val prepare: + Context.t -> + level:Int32.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + context tzresult Lwt.t + +val finalize: ?commit_message:string -> context -> Updater.validation_result + +val activate: context -> Protocol_hash.t -> context Lwt.t +val fork_test_chain: context -> Protocol_hash.t -> Time.t -> context Lwt.t + +val record_endorsement: + context -> Signature.Public_key_hash.t -> context +val allowed_endorsements: + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t +val init_endorsements: + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> + context + +val reset_internal_nonce: context -> context +val fresh_internal_nonce: context -> (context * int) tzresult +val record_internal_nonce: context -> int -> context +val internal_nonce_already_recorded: context -> int -> bool + +val add_fees: context -> Tez.t -> context tzresult Lwt.t +val add_rewards: context -> Tez.t -> context tzresult Lwt.t +val add_deposit: + context -> Signature.Public_key_hash.t -> Tez.t -> context tzresult Lwt.t + +val get_fees: context -> Tez.t +val get_rewards: context -> Tez.t +val get_deposits: context -> Tez.t Signature.Public_key_hash.Map.t + +val description: context Storage_description.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml new file mode 100644 index 000000000..5194db531 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml @@ -0,0 +1,127 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +let custom_root = RPC_path.open_root + +module Seed = struct + + module S = struct + + open Data_encoding + + let seed = + RPC_service.post_service + ~description: "Seed of the cycle to which the block belongs." + ~query: RPC_query.empty + ~input: empty + ~output: Seed.seed_encoding + RPC_path.(custom_root / "context" / "seed") + + end + + let () = + let open Services_registration in + register0 S.seed begin fun ctxt () () -> + let l = Level.current ctxt in + Seed.for_cycle ctxt l.cycle + end + + + let get ctxt block = + RPC_context.make_call0 S.seed ctxt block () () + +end + +module Nonce = struct + + type info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + + let info_encoding = + let open Data_encoding in + union [ + case (Tag 0) + ~title:"Revealed" + (obj1 (req "nonce" Nonce.encoding)) + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce) ; + case (Tag 1) + ~title:"Missing" + (obj1 (req "hash" Nonce_hash.encoding)) + (function Missing nonce -> Some nonce | _ -> None) + (fun nonce -> Missing nonce) ; + case (Tag 2) + ~title:"Forgotten" + empty + (function Forgotten -> Some () | _ -> None) + (fun () -> Forgotten) ; + ] + + module S = struct + + let get = + RPC_service.get_service + ~description: "Info about the nonce of a previous block." + ~query: RPC_query.empty + ~output: info_encoding + RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg) + + end + + let register () = + let open Services_registration in + register1 S.get begin fun ctxt raw_level () () -> + let level = Level.from_raw ctxt raw_level in + Nonce.get ctxt level >>= function + | Ok (Revealed nonce) -> return (Revealed nonce) + | Ok (Unrevealed { nonce_hash ; _ }) -> + return (Missing nonce_hash) + | Error _ -> return Forgotten + end + + let get ctxt block level = + RPC_context.make_call1 S.get ctxt block level () () + +end + +module Contract = Contract_services +module Constants = Constants_services +module Delegate = Delegate_services +module Helpers = Helpers_services +module Forge = Helpers_services.Forge +module Parse = Helpers_services.Parse +module Voting = Voting_services + +let register () = + Contract.register () ; + Constants.register () ; + Delegate.register () ; + Helpers.register () ; + Nonce.register () ; + Voting.register () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli new file mode 100644 index 000000000..f6e4a6b25 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +module Seed : sig + + val get: 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t + +end + +module Nonce : sig + + type info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + + val get: + 'a #RPC_context.simple -> + 'a -> Raw_level.t -> info shell_tzresult Lwt.t + +end + +module Contract = Contract_services +module Constants = Constants_services +module Delegate = Delegate_services +module Helpers = Helpers_services +module Forge = Helpers_services.Forge +module Parse = Helpers_services.Parse +module Voting = Voting_services + +val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml b/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml new file mode 100644 index 000000000..ec30af110 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml @@ -0,0 +1,275 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +(** Returns the proposal submitted by the most delegates. + Returns None in case of a tie or if there are no proposals. *) +let select_winning_proposal proposals = + let merge proposal vote winners = + match winners with + | None -> Some ([proposal], vote) + | Some (winners, winners_vote) as previous -> + if Compare.Int32.(vote = winners_vote) then + Some (proposal :: winners, winners_vote) + else if Compare.Int32.(vote >= winners_vote) then + Some ([proposal], vote) + else + previous in + match Protocol_hash.Map.fold merge proposals None with + | None -> None + | Some ([proposal], _) -> Some proposal + | Some _ -> None (* in case of a tie, lets do nothing. *) + +(** A proposal is approved if it has supermajority and the participation reaches + the current quorum. + Supermajority means the yays are more 8/10 of casted votes. + The participation is the ratio of all received votes, including passes, with + respect to the number of possible votes. The quorum starts at 80% and at + each vote is updated using the last expected quorum and the current + participation with the following weights: + newQ = oldQ * 8/10 + participation * 2/10 *) +let check_approval_and_update_quorum ctxt = + Vote.get_ballots ctxt >>=? fun ballots -> + Vote.listing_size ctxt >>=? fun maximum_vote -> + Vote.get_current_quorum ctxt >>=? fun expected_quorum -> + (* Note overflows: considering a maximum of 8e8 tokens, with roll size as + small as 1e3, there is a maximum of 8e5 rolls and thus votes. + In 'participation' an Int64 is used because in the worst case 'all_votes is + 8e5 and after the multiplication is 8e9, making it potentially overflow a + signed Int32 which is 2e9. *) + let casted_votes = Int32.add ballots.yay ballots.nay in + let all_votes = Int32.add casted_votes ballots.pass in + let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in + let participation = (* in centile of percentage *) + Int64.to_int32 + (Int64.div + (Int64.mul (Int64.of_int32 all_votes) 100_00L) + (Int64.of_int32 maximum_vote)) in + let outcome = Compare.Int32.(participation >= expected_quorum && + ballots.yay >= supermajority) in + let updated_quorum = + Int32.div (Int32.add (Int32.mul 8l expected_quorum) (Int32.mul 2l participation)) 10l in + Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt -> + return (ctxt, outcome) + +(** Implements the state machine of the amendment procedure. + Note that [freeze_listings], that computes the vote weight of each delegate, + is run at the beginning of each voting period. +*) +let start_new_voting_period ctxt = + Vote.get_current_period_kind ctxt >>=? function + | Proposal -> begin + Vote.get_proposals ctxt >>=? fun proposals -> + Vote.clear_proposals ctxt >>= fun ctxt -> + Vote.clear_listings ctxt >>=? fun ctxt -> + match select_winning_proposal proposals with + | None -> + Vote.freeze_listings ctxt >>=? fun ctxt -> + return ctxt + | Some proposal -> + Vote.init_current_proposal ctxt proposal >>=? fun ctxt -> + Vote.freeze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Testing_vote >>=? fun ctxt -> + return ctxt + end + | Testing_vote -> + check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + Vote.clear_ballots ctxt >>= fun ctxt -> + Vote.clear_listings ctxt >>=? fun ctxt -> + if approved then + let expiration = (* in two days maximum... *) + Time.add (Timestamp.current ctxt) (Constants.test_chain_duration ctxt) in + Vote.get_current_proposal ctxt >>=? fun proposal -> + fork_test_chain ctxt proposal expiration >>= fun ctxt -> + Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> + return ctxt + else + Vote.clear_current_proposal ctxt >>=? fun ctxt -> + Vote.freeze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> + return ctxt + | Testing -> + Vote.freeze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt -> + return ctxt + | Promotion_vote -> + check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + begin + if approved then + Vote.get_current_proposal ctxt >>=? fun proposal -> + activate ctxt proposal >>= fun ctxt -> + return ctxt + else + return ctxt + end >>=? fun ctxt -> + Vote.clear_ballots ctxt >>= fun ctxt -> + Vote.clear_listings ctxt >>=? fun ctxt -> + Vote.clear_current_proposal ctxt >>=? fun ctxt -> + Vote.freeze_listings ctxt >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> + return ctxt + +type error += (* `Branch *) + | Invalid_proposal + | Unexpected_proposal + | Unauthorized_proposal + | Too_many_proposals + | Empty_proposal + | Unexpected_ballot + | Unauthorized_ballot + +let () = + let open Data_encoding in + (* Invalid proposal *) + register_error_kind + `Branch + ~id:"invalid_proposal" + ~title:"Invalid proposal" + ~description:"Ballot provided for a proposal that is not the current one." + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal") + empty + (function Invalid_proposal -> Some () | _ -> None) + (fun () -> Invalid_proposal) ; + (* Unexpected proposal *) + register_error_kind + `Branch + ~id:"unexpected_proposal" + ~title:"Unexpected proposal" + ~description:"Proposal recorded outside of a proposal period." + ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal") + empty + (function Unexpected_proposal -> Some () | _ -> None) + (fun () -> Unexpected_proposal) ; + (* Unauthorized proposal *) + register_error_kind + `Branch + ~id:"unauthorized_proposal" + ~title:"Unauthorized proposal" + ~description:"The delegate provided for the proposal is not in the voting listings." + ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal") + empty + (function Unauthorized_proposal -> Some () | _ -> None) + (fun () -> Unauthorized_proposal) ; + (* Unexpected ballot *) + register_error_kind + `Branch + ~id:"unexpected_ballot" + ~title:"Unexpected ballot" + ~description:"Ballot recorded outside of a voting period." + ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot") + empty + (function Unexpected_ballot -> Some () | _ -> None) + (fun () -> Unexpected_ballot) ; + (* Unauthorized ballot *) + register_error_kind + `Branch + ~id:"unauthorized_ballot" + ~title:"Unauthorized ballot" + ~description:"The delegate provided for the ballot is not in the voting listings." + ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot") + empty + (function Unauthorized_ballot -> Some () | _ -> None) + (fun () -> Unauthorized_ballot) ; + (* Too many proposals *) + register_error_kind + `Branch + ~id:"too_many_proposals" + ~title:"Too many proposals" + ~description:"The delegate reached the maximum number of allowed proposals." + ~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals") + empty + (function Too_many_proposals -> Some () | _ -> None) + (fun () -> Too_many_proposals) ; + (* Empty proposal *) + register_error_kind + `Branch + ~id:"empty_proposal" + ~title:"Empty proposal" + ~description:"Proposal lists cannot be empty." + ~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal") + empty + (function Empty_proposal -> Some () | _ -> None) + (fun () -> Empty_proposal) + +(* @return [true] if [List.length l] > [n] w/o computing length *) +let rec longer_than l n = + if Compare.Int.(n < 0) then assert false else + match l with + | [] -> false + | _ :: rest -> + if Compare.Int.(n = 0) then true + else (* n > 0 *) + longer_than rest (n-1) + +let record_proposals ctxt delegate proposals = + begin match proposals with + | [] -> fail Empty_proposal + | _ :: _ -> return_unit + end >>=? fun () -> + Vote.get_current_period_kind ctxt >>=? function + | Proposal -> + Vote.in_listings ctxt delegate >>= fun in_listings -> + if in_listings then + Vote.recorded_proposal_count_for_delegate ctxt delegate >>=? fun count -> + fail_when + (longer_than proposals (Constants.max_proposals_per_delegate - count)) + Too_many_proposals >>=? fun () -> + fold_left_s + (fun ctxt proposal -> + Vote.record_proposal ctxt proposal delegate) + ctxt proposals >>=? fun ctxt -> + return ctxt + else + fail Unauthorized_proposal + | Testing_vote | Testing | Promotion_vote -> + fail Unexpected_proposal + +let record_ballot ctxt delegate proposal ballot = + Vote.get_current_period_kind ctxt >>=? function + | Testing_vote | Promotion_vote -> + Vote.get_current_proposal ctxt >>=? fun current_proposal -> + fail_unless (Protocol_hash.equal proposal current_proposal) + Invalid_proposal >>=? fun () -> + Vote.has_recorded_ballot ctxt delegate >>= fun has_ballot -> + fail_when has_ballot Unauthorized_ballot >>=? fun () -> + Vote.in_listings ctxt delegate >>= fun in_listings -> + if in_listings then + Vote.record_ballot ctxt delegate ballot + else + fail Unauthorized_ballot + | Testing | Proposal -> + fail Unexpected_ballot + +let last_of_a_voting_period ctxt l = + Compare.Int32.(Int32.succ l.Level.voting_period_position = + Constants.blocks_per_voting_period ctxt ) + +let may_start_new_voting_period ctxt = + let level = Level.current ctxt in + if last_of_a_voting_period ctxt level then + start_new_voting_period ctxt + else + return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli b/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli new file mode 100644 index 000000000..c37db2889 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli @@ -0,0 +1,79 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + Only delegates with at least one roll take part in the amendment procedure. + It works as follows: + - Proposal period: delegates can submit protocol amendment proposals using + the proposal operation. At the end of a proposal period, the proposal with + most supporters is selected and we move to a testing_vote period. + If there are no proposals, or a tie between proposals, a new proposal + period starts. + - Testing_vote period: delegates can cast votes to test or not the winning + proposal using the ballot operation. + At the end of a testing_vote period if participation reaches the quorum + and the proposal has a supermajority in favor, we proceed to a testing + period. Otherwise we go back to a proposal period. + In any case, if there is enough participation the quorum is updated. + - Testing period: a test chain is forked for the lengh of the period. + At the end of a testing period we move to a promotion_vote period. + - Promotion_vote period: delegates can cast votes to promote or not the + tested proposal using the ballot operation. + At the end of a promotion_vote period if participation reaches the quorum + and the tested proposal has a supermajority in favor, it is activated as + the new protocol. Otherwise we go back to a proposal period. + In any case, if there is enough participation the quorum is updated. +*) + +open Alpha_context + +(** If at the end of a voting period, moves to the next one following + the state machine of the amendment procedure. *) +val may_start_new_voting_period: + context -> context tzresult Lwt.t + +type error += + | Unexpected_proposal + | Unauthorized_proposal + | Too_many_proposals + | Empty_proposal + +(** Records a list of proposals for a delegate. + @raise Unexpected_proposal if [ctxt] is not in a proposal period. + @raise Unauthorized_proposal if [delegate] is not in the listing. *) +val record_proposals: + context -> + public_key_hash -> Protocol_hash.t list -> + context tzresult Lwt.t + +type error += + | Invalid_proposal + | Unexpected_ballot + | Unauthorized_ballot + +val record_ballot: + context -> + public_key_hash -> Protocol_hash.t -> Vote.ballot -> + context tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply.ml b/vendors/ligo-utils/tezos-protocol-alpha/apply.ml new file mode 100644 index 000000000..984d1fee6 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply.ml @@ -0,0 +1,1072 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Main Entry Points *) + +open Alpha_context + +type error += Wrong_voting_period of Voting_period.t * Voting_period.t (* `Temporary *) +type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t (* `Temporary *) +type error += Duplicate_endorsement of Signature.Public_key_hash.t (* `Branch *) +type error += Invalid_endorsement_level +type error += Invalid_commitment of { expected: bool } +type error += Internal_operation_replay of packed_internal_operation +type error += Cannot_originate_spendable_smart_contract (* `Permanent *) +type error += Cannot_originate_non_spendable_account (* `Permanent *) + +type error += Invalid_double_endorsement_evidence (* `Permanent *) +type error += Inconsistent_double_endorsement_evidence + of { delegate1: Signature.Public_key_hash.t ; delegate2: Signature.Public_key_hash.t } (* `Permanent *) +type error += Unrequired_double_endorsement_evidence (* `Branch*) +type error += Too_early_double_endorsement_evidence + of { level: Raw_level.t ; current: Raw_level.t } (* `Temporary *) +type error += Outdated_double_endorsement_evidence + of { level: Raw_level.t ; last: Raw_level.t } (* `Permanent *) + +type error += Invalid_double_baking_evidence + of { hash1: Block_hash.t ; + level1: Int32.t ; + hash2: Block_hash.t ; + level2: Int32.t } (* `Permanent *) +type error += Inconsistent_double_baking_evidence + of { delegate1: Signature.Public_key_hash.t ; delegate2: Signature.Public_key_hash.t } (* `Permanent *) +type error += Unrequired_double_baking_evidence (* `Branch*) +type error += Too_early_double_baking_evidence + of { level: Raw_level.t ; current: Raw_level.t } (* `Temporary *) +type error += Outdated_double_baking_evidence + of { level: Raw_level.t ; last: Raw_level.t } (* `Permanent *) +type error += Invalid_activation of { pkh : Ed25519.Public_key_hash.t } +type error += Multiple_revelation +type error += Gas_quota_exceeded_init_deserialize (* Permanent *) + +let () = + register_error_kind + `Temporary + ~id:"operation.wrong_endorsement_predecessor" + ~title:"Wrong endorsement predecessor" + ~description:"Trying to include an endorsement in a block \ + that is not the successor of the endorsed one" + ~pp:(fun ppf (e, p) -> + Format.fprintf ppf "Wrong predecessor %a, expected %a" + Block_hash.pp p Block_hash.pp e) + Data_encoding.(obj2 + (req "expected" Block_hash.encoding) + (req "provided" Block_hash.encoding)) + (function Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None) + (fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ; + register_error_kind + `Temporary + ~id:"operation.wrong_voting_period" + ~title:"Wrong voting period" + ~description:"Trying to onclude a proposal or ballot \ + meant for another voting period" + ~pp:(fun ppf (e, p) -> + Format.fprintf ppf "Wrong voting period %a, current is %a" + Voting_period.pp p Voting_period.pp e) + Data_encoding.(obj2 + (req "current" Voting_period.encoding) + (req "provided" Voting_period.encoding)) + (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None) + (fun (e, p) -> Wrong_voting_period (e, p)); + register_error_kind + `Branch + ~id:"operation.duplicate_endorsement" + ~title:"Duplicate endorsement" + ~description:"Two endorsements received from same delegate" + ~pp:(fun ppf k -> + Format.fprintf ppf "Duplicate endorsement from delegate %a (possible replay attack)." + Signature.Public_key_hash.pp_short k) + Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) + (function Duplicate_endorsement k -> Some k | _ -> None) + (fun k -> Duplicate_endorsement k); + register_error_kind + `Temporary + ~id:"operation.invalid_endorsement_level" + ~title:"Unexpected level in endorsement" + ~description:"The level of an endorsement is inconsistent with the \ + \ provided block hash." + ~pp:(fun ppf () -> + Format.fprintf ppf "Unexpected level in endorsement.") + Data_encoding.unit + (function Invalid_endorsement_level -> Some () | _ -> None) + (fun () -> Invalid_endorsement_level) ; + register_error_kind + `Permanent + ~id:"block.invalid_commitment" + ~title:"Invalid commitment in block header" + ~description:"The block header has invalid commitment." + ~pp:(fun ppf expected -> + if expected then + Format.fprintf ppf "Missing seed's nonce commitment in block header." + else + Format.fprintf ppf "Unexpected seed's nonce commitment in block header.") + Data_encoding.(obj1 (req "expected" bool)) + (function Invalid_commitment { expected } -> Some expected | _ -> None) + (fun expected -> Invalid_commitment { expected }) ; + register_error_kind + `Permanent + ~id:"internal_operation_replay" + ~title:"Internal operation replay" + ~description:"An internal operation was emitted twice by a script" + ~pp:(fun ppf (Internal_operation { nonce ; _ }) -> + Format.fprintf ppf "Internal operation %d was emitted twice by a script" nonce) + Operation.internal_operation_encoding + (function Internal_operation_replay op -> Some op | _ -> None) + (fun op -> Internal_operation_replay op) ; + register_error_kind + `Permanent + ~id:"cannot_originate_non_spendable_account" + ~title:"Cannot originate non spendable account" + ~description:"An origination was attempted \ + that would create a non spendable, non scripted contract" + ~pp:(fun ppf () -> + Format.fprintf ppf "It is not possible anymore to originate \ + a non scripted contract that is not spendable.") + Data_encoding.empty + (function Cannot_originate_non_spendable_account -> Some () | _ -> None) + (fun () -> Cannot_originate_non_spendable_account) ; + register_error_kind + `Permanent + ~id:"cannot_originate_spendable_smart_contract" + ~title:"Cannot originate spendable smart contract" + ~description:"An origination was attempted \ + that would create a spendable scripted contract" + ~pp:(fun ppf () -> + Format.fprintf ppf "It is not possible anymore to originate \ + a scripted contract that is spendable.") + Data_encoding.empty + (function Cannot_originate_spendable_smart_contract -> Some () | _ -> None) + (fun () -> Cannot_originate_spendable_smart_contract) ; + register_error_kind + `Permanent + ~id:"block.invalid_double_endorsement_evidence" + ~title:"Invalid double endorsement evidence" + ~description:"A double-endorsement evidence is malformed" + ~pp:(fun ppf () -> + Format.fprintf ppf "Malformed double-endorsement evidence") + Data_encoding.empty + (function Invalid_double_endorsement_evidence -> Some () | _ -> None) + (fun () -> Invalid_double_endorsement_evidence) ; + register_error_kind + `Permanent + ~id:"block.inconsistent_double_endorsement_evidence" + ~title:"Inconsistent double endorsement evidence" + ~description:"A double-endorsement evidence is inconsistent \ + \ (two distinct delegates)" + ~pp:(fun ppf (delegate1, delegate2) -> + Format.fprintf ppf + "Inconsistent double-endorsement evidence \ + \ (distinct delegate: %a and %a)" + Signature.Public_key_hash.pp_short delegate1 + Signature.Public_key_hash.pp_short delegate2) + Data_encoding.(obj2 + (req "delegate1" Signature.Public_key_hash.encoding) + (req "delegate2" Signature.Public_key_hash.encoding)) + (function + | Inconsistent_double_endorsement_evidence { delegate1 ; delegate2 } -> + Some (delegate1, delegate2) + | _ -> None) + (fun (delegate1, delegate2) -> + Inconsistent_double_endorsement_evidence { delegate1 ; delegate2 }) ; + register_error_kind + `Branch + ~id:"block.unrequired_double_endorsement_evidence" + ~title:"Unrequired double endorsement evidence" + ~description:"A double-endorsement evidence is unrequired" + ~pp:(fun ppf () -> + Format.fprintf ppf "A valid double-endorsement operation cannot \ + \ be applied: the associated delegate \ + \ has previously been denunciated in this cycle.") + Data_encoding.empty + (function Unrequired_double_endorsement_evidence -> Some () | _ -> None) + (fun () -> Unrequired_double_endorsement_evidence) ; + register_error_kind + `Temporary + ~id:"block.too_early_double_endorsement_evidence" + ~title:"Too early double endorsement evidence" + ~description:"A double-endorsement evidence is in the future" + ~pp:(fun ppf (level, current) -> + Format.fprintf ppf + "A double-endorsement evidence is in the future \ + \ (current level: %a, endorsement level: %a)" + Raw_level.pp current + Raw_level.pp level) + Data_encoding.(obj2 + (req "level" Raw_level.encoding) + (req "current" Raw_level.encoding)) + (function + | Too_early_double_endorsement_evidence { level ; current } -> + Some (level, current) + | _ -> None) + (fun (level, current) -> + Too_early_double_endorsement_evidence { level ; current }) ; + register_error_kind + `Permanent + ~id:"block.outdated_double_endorsement_evidence" + ~title:"Outdated double endorsement evidence" + ~description:"A double-endorsement evidence is outdated." + ~pp:(fun ppf (level, last) -> + Format.fprintf ppf + "A double-endorsement evidence is outdated \ + \ (last acceptable level: %a, endorsement level: %a)" + Raw_level.pp last + Raw_level.pp level) + Data_encoding.(obj2 + (req "level" Raw_level.encoding) + (req "last" Raw_level.encoding)) + (function + | Outdated_double_endorsement_evidence { level ; last } -> + Some (level, last) + | _ -> None) + (fun (level, last) -> + Outdated_double_endorsement_evidence { level ; last }) ; + register_error_kind + `Permanent + ~id:"block.invalid_double_baking_evidence" + ~title:"Invalid double baking evidence" + ~description:"A double-baking evidence is inconsistent \ + \ (two distinct level)" + ~pp:(fun ppf (hash1, level1, hash2, level2) -> + Format.fprintf ppf + "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)" + Block_hash.pp hash1 Block_hash.pp hash2 + level1 level2) + Data_encoding.(obj4 + (req "hash1" Block_hash.encoding) + (req "level1" int32) + (req "hash2" Block_hash.encoding) + (req "level2" int32)) + (function + | Invalid_double_baking_evidence { hash1 ; level1 ; hash2 ; level2 } -> + Some (hash1, level1, hash2, level2) + | _ -> None) + (fun (hash1, level1, hash2, level2) -> + Invalid_double_baking_evidence { hash1 ; level1 ; hash2 ; level2 }) ; + register_error_kind + `Permanent + ~id:"block.inconsistent_double_baking_evidence" + ~title:"Inconsistent double baking evidence" + ~description:"A double-baking evidence is inconsistent \ + \ (two distinct delegates)" + ~pp:(fun ppf (delegate1, delegate2) -> + Format.fprintf ppf + "Inconsistent double-baking evidence \ + \ (distinct delegate: %a and %a)" + Signature.Public_key_hash.pp_short delegate1 + Signature.Public_key_hash.pp_short delegate2) + Data_encoding.(obj2 + (req "delegate1" Signature.Public_key_hash.encoding) + (req "delegate2" Signature.Public_key_hash.encoding)) + (function + | Inconsistent_double_baking_evidence { delegate1 ; delegate2 } -> + Some (delegate1, delegate2) + | _ -> None) + (fun (delegate1, delegate2) -> + Inconsistent_double_baking_evidence { delegate1 ; delegate2 }) ; + register_error_kind + `Branch + ~id:"block.unrequired_double_baking_evidence" + ~title:"Unrequired double baking evidence" + ~description:"A double-baking evidence is unrequired" + ~pp:(fun ppf () -> + Format.fprintf ppf "A valid double-baking operation cannot \ + \ be applied: the associated delegate \ + \ has previously been denunciated in this cycle.") + Data_encoding.empty + (function Unrequired_double_baking_evidence -> Some () | _ -> None) + (fun () -> Unrequired_double_baking_evidence) ; + register_error_kind + `Temporary + ~id:"block.too_early_double_baking_evidence" + ~title:"Too early double baking evidence" + ~description:"A double-baking evidence is in the future" + ~pp:(fun ppf (level, current) -> + Format.fprintf ppf + "A double-baking evidence is in the future \ + \ (current level: %a, baking level: %a)" + Raw_level.pp current + Raw_level.pp level) + Data_encoding.(obj2 + (req "level" Raw_level.encoding) + (req "current" Raw_level.encoding)) + (function + | Too_early_double_baking_evidence { level ; current } -> + Some (level, current) + | _ -> None) + (fun (level, current) -> + Too_early_double_baking_evidence { level ; current }) ; + register_error_kind + `Permanent + ~id:"block.outdated_double_baking_evidence" + ~title:"Outdated double baking evidence" + ~description:"A double-baking evidence is outdated." + ~pp:(fun ppf (level, last) -> + Format.fprintf ppf + "A double-baking evidence is outdated \ + \ (last acceptable level: %a, baking level: %a)" + Raw_level.pp last + Raw_level.pp level) + Data_encoding.(obj2 + (req "level" Raw_level.encoding) + (req "last" Raw_level.encoding)) + (function + | Outdated_double_baking_evidence { level ; last } -> + Some (level, last) + | _ -> None) + (fun (level, last) -> + Outdated_double_baking_evidence { level ; last }) ; + register_error_kind + `Permanent + ~id:"operation.invalid_activation" + ~title:"Invalid activation" + ~description:"The given key and secret do not correspond to any \ + existing preallocated contract" + ~pp:(fun ppf pkh -> + Format.fprintf ppf "Invalid activation. The public key %a does \ + not match any commitment." + Ed25519.Public_key_hash.pp pkh + ) + Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding)) + (function Invalid_activation { pkh } -> Some pkh | _ -> None) + (fun pkh -> Invalid_activation { pkh } ) ; + register_error_kind + `Permanent + ~id:"block.multiple_revelation" + ~title:"Multiple revelations were included in a manager operation" + ~description:"A manager operation should not contain more than one revelation" + ~pp:(fun ppf () -> + Format.fprintf ppf + "Multiple revelations were included in a manager operation") + Data_encoding.empty + (function Multiple_revelation -> Some () | _ -> None) + (fun () -> Multiple_revelation) ; + register_error_kind + `Permanent + ~id:"gas_exhausted.init_deserialize" + ~title:"Not enough gas for initial deserialization of script expresions" + ~description:"Gas limit was not high enough to deserialize the \ + transaction parameters or origination script code or \ + initial storage, making the operation impossible to \ + parse within the provided gas bounds." + Data_encoding.empty + (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None) + (fun () -> Gas_quota_exceeded_init_deserialize) + +open Apply_results + +let apply_manager_operation_content : + type kind. + ( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t -> + internal:bool -> kind manager_operation -> + (context * kind successful_manager_operation_result * packed_internal_operation list) tzresult Lwt.t ) = + fun ctxt mode ~payer ~source ~internal operation -> + let before_operation = + (* This context is not used for backtracking. Only to compute + gas consumption and originations for the operation result. *) + ctxt in + Contract.must_exist ctxt source >>=? fun () -> + let spend = + (* Ignore the spendable flag for smart contracts. *) + if internal then Contract.spend_from_script else Contract.spend in + let set_delegate = + (* Ignore the delegatable flag for smart contracts. *) + if internal then Delegate.set_from_script else Delegate.set in + Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) >>=? fun ctxt -> + match operation with + | Reveal _ -> + return (* No-op: action already performed by `precheck_manager_contents`. *) + (ctxt, (Reveal_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt } : kind successful_manager_operation_result), []) + | Transaction { amount ; parameters ; destination } -> begin + spend ctxt source amount >>=? fun ctxt -> + begin match Contract.is_implicit destination with + | None -> return (ctxt, [], false) + | Some _ -> + Contract.allocated ctxt destination >>=? function + | true -> return (ctxt, [], false) + | false -> + Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) -> + return (ctxt, [ Delegate.Contract payer, Delegate.Debited origination_burn ], true) + end >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract) -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? fun (ctxt, script) -> + match script with + | None -> begin + match parameters with + | None -> return ctxt + | Some arg -> + Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *) + (* [note]: for toplevel ops, cost is nil since the + lazy value has already been forced at precheck, so + we compute and consume the full cost again *) + let cost_arg = Script.deserialized_cost arg in + Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + return ctxt + | _ -> fail (Script_interpreter.Bad_contract_parameter destination) + end >>=? fun ctxt -> + let result = + Transaction_result + { storage = None ; + big_map_diff = None; + balance_updates = + Delegate.cleanup_balance_updates + ([ Delegate.Contract source, Delegate.Debited amount ; + Contract destination, Credited amount ] + @ maybe_burn_balance_update) ; + originated_contracts = [] ; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt ; + storage_size = Z.zero ; + paid_storage_size_diff = Z.zero ; + allocated_destination_contract ; + } in + return (ctxt, result, []) + | Some script -> + begin match parameters with + | None -> + (* Forge a [Unit] parameter that will be checked by [execute]. *) + let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in + return (ctxt, unit) + | Some parameters -> + Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) + let cost_arg = Script.deserialized_cost arg in + Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> + return (ctxt, arg) + end >>=? fun (ctxt, parameter) -> + Script_interpreter.execute + ctxt mode + ~source ~payer ~self:(destination, script) ~amount ~parameter + >>=? fun { ctxt ; storage ; big_map_diff ; operations } -> + Contract.update_script_storage + ctxt destination storage big_map_diff >>=? fun ctxt -> + Fees.record_paid_storage_space + ctxt destination >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) -> + Contract.originated_from_current_nonce + ~since: before_operation + ~until: ctxt >>=? fun originated_contracts -> + let result = + Transaction_result + { storage = Some storage ; + big_map_diff; + balance_updates = + Delegate.cleanup_balance_updates + [ Contract payer, Debited fees ; + Contract source, Debited amount ; + Contract destination, Credited amount ] ; + originated_contracts ; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt ; + storage_size = new_size ; + paid_storage_size_diff ; + allocated_destination_contract } in + return (ctxt, result, operations) + end + | Origination { manager ; delegate ; script ; preorigination ; + spendable ; delegatable ; credit } -> + begin match script with + | None -> + if spendable then + return (None, ctxt) + else + fail Cannot_originate_non_spendable_account + | Some script -> + if spendable then + fail Cannot_originate_spendable_smart_contract + else + Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> + Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> + Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) -> + Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) -> + return (Some (script, big_map_diff), ctxt) + end >>=? fun (script, ctxt) -> + spend ctxt source credit >>=? fun ctxt -> + begin match preorigination with + | Some contract -> + assert internal ; + (* The preorigination field is only used to early return + the address of an originated contract in Michelson. + It cannot come from the outside. *) + return (ctxt, contract) + | None -> + Contract.fresh_contract_from_current_nonce ctxt + end >>=? fun (ctxt, contract) -> + Contract.originate ctxt contract + ~manager ~delegate ~balance:credit + ?script + ~spendable ~delegatable >>=? fun ctxt -> + Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) -> + Fees.record_paid_storage_space ctxt contract >>=? fun (ctxt, size, paid_storage_size_diff, fees) -> + let result = + Origination_result + { balance_updates = + Delegate.cleanup_balance_updates + [ Contract payer, Debited fees ; + Contract payer, Debited origination_burn ; + Contract source, Debited credit ; + Contract contract, Credited credit ] ; + originated_contracts = [ contract ] ; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt ; + storage_size = size ; + paid_storage_size_diff } in + return (ctxt, result, []) + | Delegation delegate -> + set_delegate ctxt source delegate >>=? fun ctxt -> + return (ctxt, Delegation_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt }, []) + +let apply_internal_manager_operations ctxt mode ~payer ops = + let rec apply ctxt applied worklist = + match worklist with + | [] -> Lwt.return (`Success ctxt, List.rev applied) + | (Internal_operation + ({ source ; operation ; nonce } as op)) :: rest -> + begin + if internal_nonce_already_recorded ctxt nonce then + fail (Internal_operation_replay (Internal_operation op)) + else + let ctxt = record_internal_nonce ctxt nonce in + apply_manager_operation_content + ctxt mode ~source ~payer ~internal:true operation + end >>= function + | Error errors -> + let result = + Internal_operation_result (op, Failed (manager_kind op.operation, errors)) in + let skipped = + List.rev_map + (fun (Internal_operation op) -> + Internal_operation_result (op, Skipped (manager_kind op.operation))) + rest in + Lwt.return (`Failure, List.rev (skipped @ (result :: applied))) + | Ok (ctxt, result, emitted) -> + apply ctxt + (Internal_operation_result (op, Applied result) :: applied) + (rest @ emitted) in + apply ctxt [] ops + +let precheck_manager_contents + (type kind) ctxt chain_id raw_operation (op : kind Kind.manager contents) + : context tzresult Lwt.t = + let Manager_operation { source ; fee ; counter ; operation ; gas_limit ; storage_limit } = op in + Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> + let ctxt = Gas.set_limit ctxt gas_limit in + Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> + Contract.must_be_allocated ctxt source >>=? fun () -> + Contract.check_counter_increment ctxt source counter >>=? fun () -> + begin + match operation with + | Reveal pk -> + Contract.reveal_manager_key ctxt source pk + | Transaction { parameters = Some arg ; _ } -> + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ + Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + trace Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt + | Origination { script = Some script ; _ } -> + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ + (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + trace Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt script.code >>=? fun (_code, ctxt) -> + trace Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) -> + ctxt + | _ -> return ctxt + end >>=? fun ctxt -> + Contract.get_manager_key ctxt source >>=? fun public_key -> + (* Currently, the `raw_operation` only contains one signature, so + all operations are required to be from the same manager. This may + change in the future, allowing several managers to group-sign a + sequence of transactions. *) + Operation.check_signature public_key chain_id raw_operation >>=? fun () -> + Contract.increment_counter ctxt source >>=? fun ctxt -> + Contract.spend ctxt source fee >>=? fun ctxt -> + add_fees ctxt fee >>=? fun ctxt -> + return ctxt + +let apply_manager_contents + (type kind) ctxt mode (op : kind Kind.manager contents) + : ([ `Success of context | `Failure ] * + kind manager_operation_result * + packed_internal_operation_result list) Lwt.t = + let Manager_operation + { source ; operation ; gas_limit ; storage_limit } = op in + let ctxt = Gas.set_limit ctxt gas_limit in + let ctxt = Fees.start_counting_storage_fees ctxt in + apply_manager_operation_content ctxt mode + ~source ~payer:source ~internal:false operation >>= function + | Ok (ctxt, operation_results, internal_operations) -> begin + apply_internal_manager_operations + ctxt mode ~payer:source internal_operations >>= function + | (`Success ctxt, internal_operations_results) -> begin + Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= function + | Ok ctxt -> + Lwt.return + (`Success ctxt, Applied operation_results, internal_operations_results) + | Error errors -> + Lwt.return + (`Failure, Backtracked (operation_results, Some errors), internal_operations_results) + end + | (`Failure, internal_operations_results) -> + Lwt.return + (`Failure, Applied operation_results, internal_operations_results) + end + | Error errors -> + Lwt.return + (`Failure, Failed (manager_kind operation, errors), []) + +let skipped_operation_result + : type kind. kind manager_operation -> kind manager_operation_result + = function operation -> + match operation with + | Reveal _ -> + Applied ( Reveal_result { consumed_gas = Z.zero } : kind successful_manager_operation_result ) + | _ -> Skipped (manager_kind operation) + +let rec mark_skipped + : type kind. + baker : Signature.Public_key_hash.t -> Level.t -> kind Kind.manager contents_list -> + kind Kind.manager contents_result_list = fun ~baker level -> function + | Single (Manager_operation { source ; fee ; operation } ) -> + Single_result + (Manager_operation_result + { balance_updates = + Delegate.cleanup_balance_updates + [ Contract source, Debited fee ; + Fees (baker, level.cycle), Credited fee ] ; + operation_result = skipped_operation_result operation ; + internal_operation_results = [] }) + | Cons (Manager_operation { source ; fee ; operation } , rest) -> + Cons_result + (Manager_operation_result { + balance_updates = + Delegate.cleanup_balance_updates + [ Contract source, Debited fee ; + Fees (baker, level.cycle), Credited fee ] ; + operation_result = skipped_operation_result operation ; + internal_operation_results = [] }, + mark_skipped ~baker level rest) + +let rec precheck_manager_contents_list + : type kind. + Alpha_context.t -> Chain_id.t -> _ Operation.t -> kind Kind.manager contents_list -> + context tzresult Lwt.t = + fun ctxt chain_id raw_operation contents_list -> + match contents_list with + | Single (Manager_operation _ as op) -> + precheck_manager_contents ctxt chain_id raw_operation op + | Cons (Manager_operation _ as op, rest) -> + precheck_manager_contents ctxt chain_id raw_operation op >>=? fun ctxt -> + precheck_manager_contents_list ctxt chain_id raw_operation rest + +let rec apply_manager_contents_list_rec + : type kind. + Alpha_context.t -> Script_ir_translator.unparsing_mode -> + public_key_hash -> kind Kind.manager contents_list -> + ([ `Success of context | `Failure ] * + kind Kind.manager contents_result_list) Lwt.t = + fun ctxt mode baker contents_list -> + let level = Level.current ctxt in + match contents_list with + | Single (Manager_operation { source ; fee ; _ } as op) -> begin + apply_manager_contents ctxt mode op + >>= fun (ctxt_result, operation_result, internal_operation_results) -> + let result = + Manager_operation_result { + balance_updates = + Delegate.cleanup_balance_updates + [ Contract source, Debited fee ; + Fees (baker, level.cycle), Credited fee ] ; + operation_result ; + internal_operation_results ; + } in + Lwt.return (ctxt_result, Single_result (result)) + end + | Cons (Manager_operation { source ; fee ; _ } as op, rest) -> + apply_manager_contents ctxt mode op >>= function + | (`Failure, operation_result, internal_operation_results) -> + let result = + Manager_operation_result { + balance_updates = + Delegate.cleanup_balance_updates + [ Contract source, Debited fee ; + Fees (baker, level.cycle), Credited fee ] ; + operation_result ; + internal_operation_results ; + } in + Lwt.return (`Failure, Cons_result (result, mark_skipped ~baker level rest)) + | (`Success ctxt, operation_result, internal_operation_results) -> + let result = + Manager_operation_result { + balance_updates = + Delegate.cleanup_balance_updates + [ Contract source, Debited fee ; + Fees (baker, level.cycle), Credited fee ] ; + operation_result ; + internal_operation_results ; + } in + apply_manager_contents_list_rec ctxt mode baker rest >>= fun (ctxt_result, results) -> + Lwt.return (ctxt_result, Cons_result (result, results)) + +let mark_backtracked results = + let rec mark_contents_list + : type kind. kind Kind.manager contents_result_list -> kind Kind.manager contents_result_list + = function + | Single_result (Manager_operation_result op) -> + Single_result (Manager_operation_result + { balance_updates = + op.balance_updates ; + operation_result = + mark_manager_operation_result op.operation_result ; + internal_operation_results = + List.map mark_internal_operation_results op.internal_operation_results}) + | Cons_result (Manager_operation_result op, rest) -> + Cons_result (Manager_operation_result + { balance_updates = + op.balance_updates ; + operation_result = + mark_manager_operation_result op.operation_result ; + internal_operation_results = + List.map mark_internal_operation_results op.internal_operation_results}, + mark_contents_list rest) + and mark_internal_operation_results (Internal_operation_result (kind, result)) = + (Internal_operation_result (kind, mark_manager_operation_result result)) + and mark_manager_operation_result + : type kind. kind manager_operation_result -> kind manager_operation_result + = function + | Failed _ | Skipped _ | Backtracked _ as result -> result + | Applied (Reveal_result _) as result -> result + | Applied result -> Backtracked (result, None) in + mark_contents_list results + +let apply_manager_contents_list ctxt mode baker contents_list = + apply_manager_contents_list_rec ctxt mode baker contents_list >>= fun (ctxt_result, results) -> + match ctxt_result with + | `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results) + | `Success ctxt -> Lwt.return (ctxt, results) + +let apply_contents_list + (type kind) ctxt ~partial chain_id mode pred_block baker + (operation : kind operation) + (contents_list : kind contents_list) + : (context * kind contents_result_list) tzresult Lwt.t = + match contents_list with + | Single (Endorsement { level }) -> + let block = operation.shell.branch in + fail_unless + (Block_hash.equal block pred_block) + (Wrong_endorsement_predecessor (pred_block, block)) >>=? fun () -> + let current_level = (Level.current ctxt).level in + fail_unless + Raw_level.(succ level = current_level) + Invalid_endorsement_level >>=? fun () -> + Baking.check_endorsement_rights ctxt chain_id operation >>=? fun (delegate, slots, used) -> + if used then fail (Duplicate_endorsement delegate) + else + let ctxt = record_endorsement ctxt delegate in + let gap = List.length slots in + let ctxt = Fitness.increase ~gap ctxt in + Lwt.return + Tez.(Constants.endorsement_security_deposit ctxt *? + Int64.of_int gap) >>=? fun deposit -> + begin + if partial then + Delegate.freeze_deposit ctxt delegate deposit + else + add_deposit ctxt delegate deposit + end >>=? fun ctxt -> + Global.get_last_block_priority ctxt >>=? fun block_priority -> + Baking.endorsement_reward ctxt ~block_priority gap >>=? fun reward -> + Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt -> + let level = Level.from_raw ctxt level in + return (ctxt, Single_result + (Endorsement_result + { balance_updates = Delegate.cleanup_balance_updates + [ Contract (Contract.implicit_contract delegate), Debited deposit; + Deposits (delegate, level.cycle), Credited deposit; + Rewards (delegate, level.cycle), Credited reward; ] ; + delegate ; slots })) + | Single (Seed_nonce_revelation { level ; nonce }) -> + let level = Level.from_raw ctxt level in + Nonce.reveal ctxt level nonce >>=? fun ctxt -> + let seed_nonce_revelation_tip = + Constants.seed_nonce_revelation_tip ctxt in + add_rewards ctxt seed_nonce_revelation_tip >>=? fun ctxt -> + return (ctxt, Single_result + (Seed_nonce_revelation_result + [ Rewards (baker, level.cycle), Credited seed_nonce_revelation_tip ])) + | Single (Double_endorsement_evidence { op1 ; op2 }) -> begin + match op1.protocol_data.contents, op2.protocol_data.contents with + | Single (Endorsement e1), + Single (Endorsement e2) + when Raw_level.(e1.level = e2.level) && + not (Block_hash.equal op1.shell.branch op2.shell.branch) -> + let level = Level.from_raw ctxt e1.level in + let oldest_level = Level.last_allowed_fork_level ctxt in + fail_unless Level.(level < Level.current ctxt) + (Too_early_double_endorsement_evidence + { level = level.level ; + current = (Level.current ctxt).level }) >>=? fun () -> + fail_unless Raw_level.(oldest_level <= level.level) + (Outdated_double_endorsement_evidence + { level = level.level ; + last = oldest_level }) >>=? fun () -> + Baking.check_endorsement_rights ctxt chain_id op1 >>=? fun (delegate1, _, _) -> + Baking.check_endorsement_rights ctxt chain_id op2 >>=? fun (delegate2, _, _) -> + fail_unless + (Signature.Public_key_hash.equal delegate1 delegate2) + (Inconsistent_double_endorsement_evidence + { delegate1 ; delegate2 }) >>=? fun () -> + Delegate.has_frozen_balance ctxt delegate1 level.cycle >>=? fun valid -> + fail_unless valid Unrequired_double_endorsement_evidence >>=? fun () -> + Delegate.punish ctxt delegate1 level.cycle >>=? fun (ctxt, balance) -> + Lwt.return Tez.(balance.deposit +? balance.fees) >>=? fun burned -> + let reward = + match Tez.(burned /? 2L) with + | Ok v -> v + | Error _ -> Tez.zero in + add_rewards ctxt reward >>=? fun ctxt -> + let current_cycle = (Level.current ctxt).cycle in + return (ctxt, Single_result + (Double_endorsement_evidence_result + (Delegate.cleanup_balance_updates [ + Deposits (delegate1, level.cycle), Debited balance.deposit ; + Fees (delegate1, level.cycle), Debited balance.fees ; + Rewards (delegate1, level.cycle), Debited balance.rewards ; + Rewards (baker, current_cycle), Credited reward ]))) + | _, _ -> fail Invalid_double_endorsement_evidence + end + | Single (Double_baking_evidence { bh1 ; bh2 }) -> + let hash1 = Block_header.hash bh1 in + let hash2 = Block_header.hash bh2 in + fail_unless + (Compare.Int32.(bh1.shell.level = bh2.shell.level) && + not (Block_hash.equal hash1 hash2)) + (Invalid_double_baking_evidence + { hash1 ; + level1 = bh1.shell.level ; + hash2 ; + level2 = bh2.shell.level ; + }) >>=? fun () -> + Lwt.return (Raw_level.of_int32 bh1.shell.level) >>=? fun raw_level -> + let oldest_level = Level.last_allowed_fork_level ctxt in + fail_unless Raw_level.(raw_level < (Level.current ctxt).level) + (Too_early_double_baking_evidence + { level = raw_level ; + current = (Level.current ctxt).level }) >>=? fun () -> + fail_unless Raw_level.(oldest_level <= raw_level) + (Outdated_double_baking_evidence + { level = raw_level ; + last = oldest_level }) >>=? fun () -> + let level = Level.from_raw ctxt raw_level in + Roll.baking_rights_owner + ctxt level ~priority:bh1.protocol_data.contents.priority >>=? fun delegate1 -> + Baking.check_signature bh1 chain_id delegate1 >>=? fun () -> + Roll.baking_rights_owner + ctxt level ~priority:bh2.protocol_data.contents.priority >>=? fun delegate2 -> + Baking.check_signature bh2 chain_id delegate2 >>=? fun () -> + fail_unless + (Signature.Public_key.equal delegate1 delegate2) + (Inconsistent_double_baking_evidence + { delegate1 = Signature.Public_key.hash delegate1 ; + delegate2 = Signature.Public_key.hash delegate2 }) >>=? fun () -> + let delegate = Signature.Public_key.hash delegate1 in + Delegate.has_frozen_balance ctxt delegate level.cycle >>=? fun valid -> + fail_unless valid Unrequired_double_baking_evidence >>=? fun () -> + Delegate.punish ctxt delegate level.cycle >>=? fun (ctxt, balance) -> + Lwt.return Tez.(balance.deposit +? balance.fees) >>=? fun burned -> + let reward = + match Tez.(burned /? 2L) with + | Ok v -> v + | Error _ -> Tez.zero in + add_rewards ctxt reward >>=? fun ctxt -> + let current_cycle = (Level.current ctxt).cycle in + return (ctxt, Single_result + (Double_baking_evidence_result + (Delegate.cleanup_balance_updates [ + Deposits (delegate, level.cycle), Debited balance.deposit ; + Fees (delegate, level.cycle), Debited balance.fees ; + Rewards (delegate, level.cycle), Debited balance.rewards ; + Rewards (baker, current_cycle), Credited reward ; ]))) + | Single (Activate_account { id = pkh ; activation_code }) -> begin + let blinded_pkh = + Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in + Commitment.get_opt ctxt blinded_pkh >>=? function + | None -> fail (Invalid_activation { pkh }) + | Some amount -> + Commitment.delete ctxt blinded_pkh >>=? fun ctxt -> + let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in + Contract.(credit ctxt contract amount) >>=? fun ctxt -> + return (ctxt, Single_result (Activate_account_result + [ Contract contract, Credited amount ])) + end + | Single (Proposals { source ; period ; proposals }) -> + Roll.delegate_pubkey ctxt source >>=? fun delegate -> + Operation.check_signature delegate chain_id operation >>=? fun () -> + let level = Level.current ctxt in + fail_unless Voting_period.(level.voting_period = period) + (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> + Amendment.record_proposals ctxt source proposals >>=? fun ctxt -> + return (ctxt, Single_result Proposals_result) + | Single (Ballot { source ; period ; proposal ; ballot }) -> + Roll.delegate_pubkey ctxt source >>=? fun delegate -> + Operation.check_signature delegate chain_id operation >>=? fun () -> + let level = Level.current ctxt in + fail_unless Voting_period.(level.voting_period = period) + (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> + Amendment.record_ballot ctxt source proposal ballot >>=? fun ctxt -> + return (ctxt, Single_result Ballot_result) + | Single (Manager_operation _) as op -> + precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> + apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) -> + return (ctxt, result) + | Cons (Manager_operation _, _) as op -> + precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> + apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) -> + return (ctxt, result) + +let apply_operation ctxt ~partial chain_id mode pred_block baker hash operation = + let ctxt = Contract.init_origination_nonce ctxt hash in + apply_contents_list + ctxt ~partial chain_id mode pred_block baker operation + operation.protocol_data.contents >>=? fun (ctxt, result) -> + let ctxt = Gas.set_unlimited ctxt in + let ctxt = Contract.unset_origination_nonce ctxt in + return (ctxt, { contents = result }) + +let may_snapshot_roll ctxt = + let level = Alpha_context.Level.current ctxt in + let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in + if Compare.Int32.equal + (Int32.rem level.cycle_position blocks_per_roll_snapshot) + (Int32.pred blocks_per_roll_snapshot) + then + Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> + return ctxt + else + return ctxt + +let may_start_new_cycle ctxt = + Baking.dawn_of_a_new_cycle ctxt >>=? function + | None -> return (ctxt, [], []) + | Some last_cycle -> + Seed.cycle_end ctxt last_cycle >>=? fun (ctxt, unrevealed) -> + Roll.cycle_end ctxt last_cycle >>=? fun ctxt -> + Delegate.cycle_end ctxt last_cycle unrevealed >>=? fun (ctxt, update_balances, deactivated) -> + Bootstrap.cycle_end ctxt last_cycle >>=? fun ctxt -> + return (ctxt, update_balances, deactivated) + +let begin_full_construction ctxt pred_timestamp protocol_data = + Baking.check_baking_rights + ctxt protocol_data pred_timestamp >>=? fun delegate_pk -> + let ctxt = Fitness.increase ctxt in + match Level.pred ctxt (Level.current ctxt) with + | None -> assert false (* genesis *) + | Some pred_level -> + Baking.endorsement_rights ctxt pred_level >>=? fun rights -> + let ctxt = init_endorsements ctxt rights in + return (ctxt, protocol_data, delegate_pk) + +let begin_partial_construction ctxt = + let ctxt = Fitness.increase ctxt in + match Level.pred ctxt (Level.current ctxt) with + | None -> assert false (* genesis *) + | Some pred_level -> + Baking.endorsement_rights ctxt pred_level >>=? fun rights -> + let ctxt = init_endorsements ctxt rights in + return ctxt + +let begin_application ctxt chain_id block_header pred_timestamp = + let current_level = Alpha_context.Level.current ctxt in + Baking.check_proof_of_work_stamp ctxt block_header >>=? fun () -> + Baking.check_fitness_gap ctxt block_header >>=? fun () -> + Baking.check_baking_rights + ctxt block_header.protocol_data.contents pred_timestamp >>=? fun delegate_pk -> + Baking.check_signature block_header chain_id delegate_pk >>=? fun () -> + let has_commitment = + match block_header.protocol_data.contents.seed_nonce_hash with + | None -> false + | Some _ -> true in + fail_unless + Compare.Bool.(has_commitment = current_level.expected_commitment) + (Invalid_commitment + { expected = current_level.expected_commitment }) >>=? fun () -> + let ctxt = Fitness.increase ctxt in + match Level.pred ctxt (Level.current ctxt) with + | None -> assert false (* genesis *) + | Some pred_level -> + Baking.endorsement_rights ctxt pred_level >>=? fun rights -> + let ctxt = init_endorsements ctxt rights in + return (ctxt, delegate_pk) + +let finalize_application ctxt protocol_data delegate = + let deposit = Constants.block_security_deposit ctxt in + add_deposit ctxt delegate deposit >>=? fun ctxt -> + let reward = (Constants.block_reward ctxt) in + add_rewards ctxt reward >>=? fun ctxt -> + Signature.Public_key_hash.Map.fold + (fun delegate deposit ctxt -> + ctxt >>=? fun ctxt -> + Delegate.freeze_deposit ctxt delegate deposit) + (get_deposits ctxt) + (return ctxt) >>=? fun ctxt -> + (* end of level (from this point nothing should fail) *) + let fees = Alpha_context.get_fees ctxt in + Delegate.freeze_fees ctxt delegate fees >>=? fun ctxt -> + let rewards = Alpha_context.get_rewards ctxt in + Delegate.freeze_rewards ctxt delegate rewards >>=? fun ctxt -> + begin + match protocol_data.Block_header.seed_nonce_hash with + | None -> return ctxt + | Some nonce_hash -> + Nonce.record_hash ctxt + { nonce_hash ; delegate ; rewards ; fees } + end >>=? fun ctxt -> + Alpha_context.Global.set_last_block_priority + ctxt protocol_data.priority >>=? fun ctxt -> + (* end of cycle *) + may_snapshot_roll ctxt >>=? fun ctxt -> + may_start_new_cycle ctxt >>=? fun (ctxt, balance_updates, deactivated) -> + Amendment.may_start_new_voting_period ctxt >>=? fun ctxt -> + let cycle = (Level.current ctxt).cycle in + let balance_updates = + Delegate.(cleanup_balance_updates + ([ Contract (Contract.implicit_contract delegate), Debited deposit ; + Deposits (delegate, cycle), Credited deposit ; + Rewards (delegate, cycle), Credited reward ] @ balance_updates)) in + let consumed_gas = Z.sub (Constants.hard_gas_limit_per_block ctxt) (Alpha_context.Gas.block_level ctxt) in + Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> + let receipt = Apply_results.{ baker = delegate ; + level = Level.current ctxt; + voting_period_kind ; + nonce_hash = protocol_data.seed_nonce_hash ; + consumed_gas ; + deactivated ; + balance_updates } in + return (ctxt, receipt) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml new file mode 100644 index 000000000..0ef56ef6e --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml @@ -0,0 +1,988 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Data_encoding + +let error_encoding = + def "error" + ~description: + "The full list of RPC errors would be too long to include.\n\ + It is available at RPC `/errors` (GET).\n\ + Errors specific to protocol Alpha have an id that starts with `proto.alpha`." @@ + splitted + ~json:(conv + (fun err -> + Data_encoding.Json.construct Error_monad.error_encoding err) + (fun json -> + Data_encoding.Json.destruct Error_monad.error_encoding json) + json) + ~binary:Error_monad.error_encoding + +type _ successful_manager_operation_result = + | Reveal_result : + { consumed_gas : Z.t + } -> Kind.reveal successful_manager_operation_result + | Transaction_result : + { storage : Script.expr option ; + big_map_diff : Contract.big_map_diff option ; + balance_updates : Delegate.balance_updates ; + originated_contracts : Contract.t list ; + consumed_gas : Z.t ; + storage_size : Z.t ; + paid_storage_size_diff : Z.t ; + allocated_destination_contract : bool ; + } -> Kind.transaction successful_manager_operation_result + | Origination_result : + { balance_updates : Delegate.balance_updates ; + originated_contracts : Contract.t list ; + consumed_gas : Z.t ; + storage_size : Z.t ; + paid_storage_size_diff : Z.t ; + } -> Kind.origination successful_manager_operation_result + | Delegation_result : + { consumed_gas : Z.t + } -> Kind.delegation successful_manager_operation_result + +type packed_successful_manager_operation_result = + | Successful_manager_result : + 'kind successful_manager_operation_result -> packed_successful_manager_operation_result + +type 'kind manager_operation_result = + | Applied of 'kind successful_manager_operation_result + | Backtracked of 'kind successful_manager_operation_result * error list option + | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result + | Skipped : 'kind Kind.manager -> 'kind manager_operation_result + +type packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation * 'kind manager_operation_result -> packed_internal_operation_result + +module Manager_result = struct + + type 'kind case = + MCase : { + op_case: 'kind Operation.Encoding.Manager_operations.case ; + encoding: 'a Data_encoding.t ; + kind: 'kind Kind.manager ; + iselect: + packed_internal_operation_result -> + ('kind internal_operation * 'kind manager_operation_result) option; + select: + packed_successful_manager_operation_result -> + 'kind successful_manager_operation_result option ; + proj: 'kind successful_manager_operation_result -> 'a ; + inj: 'a -> 'kind successful_manager_operation_result ; + t: 'kind manager_operation_result Data_encoding.t ; + } -> 'kind case + + let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj = + let Operation.Encoding.Manager_operations.MCase { name ; _ } = op_case in + let t = + def (Format.asprintf "operation.alpha.operation_result.%s" name) @@ + union ~tag_size:`Uint8 [ + case (Tag 0) + ~title:"Applied" + (merge_objs + (obj1 + (req "status" (constant "applied"))) + encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Backtracked _ -> None + | Applied o -> + match select (Successful_manager_result o) with + | None -> None + | Some o -> Some ((), proj o)) + (fun ((), x) -> (Applied (inj x))) ; + case (Tag 1) + ~title:"Failed" + (obj2 + (req "status" (constant "failed")) + (req "errors" (list error_encoding))) + (function (Failed (_, errs)) -> Some ((), errs) | _ -> None) + (fun ((), errs) -> Failed (kind, errs)) ; + case (Tag 2) + ~title:"Skipped" + (obj1 (req "status" (constant "skipped"))) + (function Skipped _ -> Some () | _ -> None) + (fun () -> Skipped kind) ; + case (Tag 3) + ~title:"Backtracked" + (merge_objs + (obj2 + (req "status" (constant "backtracked")) + (opt "errors" (list error_encoding))) + encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Applied _ -> None + | Backtracked (o, errs) -> + match select (Successful_manager_result o) with + | None -> None + | Some o -> Some (((), errs), proj o)) + (fun (((), errs), x) -> (Backtracked (inj x, errs))) ; + ] in + MCase { op_case ; encoding ; kind ; iselect ; select ; proj ; inj ; t } + + let reveal_case = + make + ~op_case: Operation.Encoding.Manager_operations.reveal_case + ~encoding: Data_encoding.(obj1 (dft "consumed_gas" z Z.zero)) + + ~iselect: + (function + | Internal_operation_result + ({ operation = Reveal _ ; _} as op, res) -> + Some (op, res) + | _ -> None) + ~select: + (function + | Successful_manager_result (Reveal_result _ as op) -> Some op + | _ -> None) + ~kind: Kind.Reveal_manager_kind + ~proj: (function Reveal_result { consumed_gas } -> consumed_gas) + ~inj: (fun consumed_gas -> Reveal_result { consumed_gas }) + + let transaction_case = + make + ~op_case: Operation.Encoding.Manager_operations.transaction_case + ~encoding: + (obj8 + (opt "storage" Script.expr_encoding) + (opt "big_map_diff" Contract.big_map_diff_encoding) + (dft "balance_updates" Delegate.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.encoding) []) + (dft "consumed_gas" z Z.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero) + (dft "allocated_destination_contract" bool false)) + ~iselect: + (function + | Internal_operation_result + ({ operation = Transaction _ ; _} as op, res) -> + Some (op, res) + | _ -> None) + ~select: + (function + | Successful_manager_result (Transaction_result _ as op) -> Some op + | _ -> None) + ~kind: Kind.Transaction_manager_kind + ~proj: + (function + | Transaction_result + { storage ; big_map_diff ; balance_updates ; + originated_contracts ; consumed_gas ; + storage_size ; paid_storage_size_diff ; + allocated_destination_contract } -> + (storage, big_map_diff, balance_updates, + originated_contracts, consumed_gas, + storage_size, paid_storage_size_diff, + allocated_destination_contract)) + ~inj: + (fun (storage, big_map_diff, balance_updates, + originated_contracts, consumed_gas, + storage_size, paid_storage_size_diff, + allocated_destination_contract) -> + Transaction_result { storage ; big_map_diff ; balance_updates ; + originated_contracts ; consumed_gas ; + storage_size ; paid_storage_size_diff ; + allocated_destination_contract }) + + let origination_case = + make + ~op_case: Operation.Encoding.Manager_operations.origination_case + ~encoding: + (obj5 + (dft "balance_updates" Delegate.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.encoding) []) + (dft "consumed_gas" z Z.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero)) + ~iselect: + (function + | Internal_operation_result + ({ operation = Origination _ ; _} as op, res) -> + Some (op, res) + | _ -> None) + ~select: + (function + | Successful_manager_result (Origination_result _ as op) -> Some op + | _ -> None) + ~proj: + (function + | Origination_result + { balance_updates ; + originated_contracts ; consumed_gas ; + storage_size ; paid_storage_size_diff } -> + (balance_updates, + originated_contracts, consumed_gas, + storage_size, paid_storage_size_diff)) + ~kind: Kind.Origination_manager_kind + ~inj: + (fun (balance_updates, + originated_contracts, consumed_gas, + storage_size, paid_storage_size_diff) -> + Origination_result + { balance_updates ; + originated_contracts ; consumed_gas ; + storage_size ; paid_storage_size_diff }) + + let delegation_case = + make + ~op_case: Operation.Encoding.Manager_operations.delegation_case + ~encoding: Data_encoding.(obj1 (dft "consumed_gas" z Z.zero)) + ~iselect: + (function + | Internal_operation_result + ({ operation = Delegation _ ; _} as op, res) -> + Some (op, res) + | _ -> None) + ~select: + (function + | Successful_manager_result (Delegation_result _ as op) -> Some op + | _ -> None) + ~kind: Kind.Delegation_manager_kind + ~proj: (function Delegation_result { consumed_gas } -> consumed_gas) + ~inj: (fun consumed_gas -> Delegation_result { consumed_gas }) + +end + +let internal_operation_result_encoding : + packed_internal_operation_result Data_encoding.t = + let make (type kind) + (Manager_result.MCase res_case : kind Manager_result.case) = + let Operation.Encoding.Manager_operations.MCase op_case = res_case.op_case in + case (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs + op_case.encoding + (obj1 (req "result" res_case.t)))) + (fun op -> + match res_case.iselect op with + | Some (op, res) -> + Some (((), op.source, op.nonce), + (op_case.proj op.operation, res)) + | None -> None) + (fun (((), source, nonce), (op, res)) -> + let op = { source ; operation = op_case.inj op ; nonce } in + Internal_operation_result (op, res)) in + def "operation.alpha.internal_operation_result" @@ + union [ + make Manager_result.reveal_case ; + make Manager_result.transaction_case ; + make Manager_result.origination_case ; + make Manager_result.delegation_case ; + ] + +type 'kind contents_result = + | Endorsement_result : + { balance_updates : Delegate.balance_updates ; + delegate : Signature.Public_key_hash.t ; + slots: int list ; + } -> Kind.endorsement contents_result + | Seed_nonce_revelation_result : + Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result + | Double_endorsement_evidence_result : + Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result + | Double_baking_evidence_result : + Delegate.balance_updates -> Kind.double_baking_evidence contents_result + | Activate_account_result : + Delegate.balance_updates -> Kind.activate_account contents_result + | Proposals_result : Kind.proposals contents_result + | Ballot_result : Kind.ballot contents_result + | Manager_operation_result : + { balance_updates : Delegate.balance_updates ; + operation_result : 'kind manager_operation_result ; + internal_operation_results : packed_internal_operation_result list ; + } -> 'kind Kind.manager contents_result + +type packed_contents_result = + | Contents_result : 'kind contents_result -> packed_contents_result + +type packed_contents_and_result = + | Contents_and_result : + 'kind Operation.contents * 'kind contents_result -> packed_contents_and_result + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +let equal_manager_kind + : type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option + = fun ka kb -> match ka, kb with + | Kind.Reveal_manager_kind, Kind.Reveal_manager_kind -> Some Eq + | Kind.Reveal_manager_kind, _ -> None + | Kind.Transaction_manager_kind, Kind.Transaction_manager_kind -> Some Eq + | Kind.Transaction_manager_kind, _ -> None + | Kind.Origination_manager_kind, Kind.Origination_manager_kind -> Some Eq + | Kind.Origination_manager_kind, _ -> None + | Kind.Delegation_manager_kind, Kind.Delegation_manager_kind -> Some Eq + | Kind.Delegation_manager_kind, _ -> None + +module Encoding = struct + + type 'kind case = + Case : { op_case: 'kind Operation.Encoding.case ; + encoding: 'a Data_encoding.t ; + select: packed_contents_result -> 'kind contents_result option ; + mselect: packed_contents_and_result -> ('kind contents * 'kind contents_result) option ; + proj: 'kind contents_result -> 'a ; + inj: 'a -> 'kind contents_result ; + } -> 'kind case + + let tagged_case tag name args proj inj = + let open Data_encoding in + case tag + ~title:(String.capitalize_ascii name) + (merge_objs + (obj1 (req "kind" (constant name))) + args) + (fun x -> match proj x with None -> None | Some x -> Some ((), x)) + (fun ((), x) -> inj x) + + let endorsement_case = + Case { + op_case = Operation.Encoding.endorsement_case ; + encoding = + (obj3 + (req "balance_updates" Delegate.balance_updates_encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "slots" (list uint8))); + select = + (function + | Contents_result (Endorsement_result _ as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Endorsement _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = + (function + | Endorsement_result { balance_updates ; delegate ; slots } + -> (balance_updates, delegate, slots)) ; + inj = + (fun (balance_updates, delegate, slots) -> + Endorsement_result { balance_updates ; delegate ; slots }) + } + + let seed_nonce_revelation_case = + Case { + op_case = Operation.Encoding.seed_nonce_revelation_case ; + encoding = + (obj1 + (req "balance_updates" Delegate.balance_updates_encoding)) ; + select = + (function + | Contents_result (Seed_nonce_revelation_result _ as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Seed_nonce_revelation _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = (fun (Seed_nonce_revelation_result bus) -> bus) ; + inj = (fun bus -> Seed_nonce_revelation_result bus) ; + } + + let double_endorsement_evidence_case = + Case { + op_case = Operation.Encoding.double_endorsement_evidence_case ; + encoding = + (obj1 + (req "balance_updates" Delegate.balance_updates_encoding)) ; + select = + (function + | Contents_result (Double_endorsement_evidence_result _ as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Double_endorsement_evidence _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = + (fun (Double_endorsement_evidence_result bus) -> bus) ; + inj = (fun bus -> Double_endorsement_evidence_result bus) + } + + let double_baking_evidence_case = + Case { + op_case = Operation.Encoding.double_baking_evidence_case ; + encoding = + (obj1 + (req "balance_updates" Delegate.balance_updates_encoding)) ; + select = + (function + | Contents_result (Double_baking_evidence_result _ as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Double_baking_evidence _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = + (fun (Double_baking_evidence_result bus) -> bus) ; + inj = (fun bus -> Double_baking_evidence_result bus) ; + } + + let activate_account_case = + Case { + op_case = Operation.Encoding.activate_account_case ; + encoding = + (obj1 + (req "balance_updates" Delegate.balance_updates_encoding)) ; + select = + (function + | Contents_result (Activate_account_result _ as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Activate_account _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = (fun (Activate_account_result bus) -> bus) ; + inj = (fun bus -> Activate_account_result bus) ; + } + + let proposals_case = + Case { + op_case = Operation.Encoding.proposals_case ; + encoding = Data_encoding.empty ; + select = + (function + | Contents_result (Proposals_result as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Proposals _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = (fun Proposals_result -> ()) ; + inj = (fun () -> Proposals_result) ; + } + + let ballot_case = + Case { + op_case = Operation.Encoding.ballot_case ; + encoding = Data_encoding.empty ; + select = + (function + | Contents_result (Ballot_result as op) -> Some op + | _ -> None) ; + mselect = + (function + | Contents_and_result (Ballot _ as op, res) -> Some (op, res) + | _ -> None) ; + proj = (fun Ballot_result -> ()) ; + inj = (fun () -> Ballot_result) ; + } + + let make_manager_case + (type kind) + (Operation.Encoding.Case op_case : kind Kind.manager Operation.Encoding.case) + (Manager_result.MCase res_case : kind Manager_result.case) + mselect = + Case { + op_case = Operation.Encoding.Case op_case ; + encoding = + (obj3 + (req "balance_updates" Delegate.balance_updates_encoding) + (req "operation_result" res_case.t) + (dft "internal_operation_results" + (list internal_operation_result_encoding) [])) ; + select = + (function + | Contents_result + (Manager_operation_result + ({ operation_result = Applied res ; _ } as op)) -> begin + match res_case.select (Successful_manager_result res) with + | Some res -> + Some (Manager_operation_result + { op with operation_result = Applied res }) + | None -> None + end + | Contents_result + (Manager_operation_result + ({ operation_result = Backtracked (res, errs) ; _ } as op)) -> begin + match res_case.select (Successful_manager_result res) with + | Some res -> + Some (Manager_operation_result + { op with operation_result = Backtracked (res, errs) }) + | None -> None + end + | Contents_result + (Manager_operation_result + ({ operation_result = Skipped kind ; _ } as op)) -> + begin match equal_manager_kind kind res_case.kind with + | None -> None + | Some Eq -> + Some (Manager_operation_result + { op with operation_result = Skipped kind }) + end + | Contents_result + (Manager_operation_result + ({ operation_result = Failed (kind, errs) ; _ } as op)) -> + begin match equal_manager_kind kind res_case.kind with + | None -> None + | Some Eq -> + Some (Manager_operation_result + { op with operation_result = Failed (kind, errs) }) + end + | Contents_result Ballot_result -> None + | Contents_result (Endorsement_result _) -> None + | Contents_result (Seed_nonce_revelation_result _) -> None + | Contents_result (Double_endorsement_evidence_result _) -> None + | Contents_result (Double_baking_evidence_result _) -> None + | Contents_result (Activate_account_result _) -> None + | Contents_result Proposals_result -> None) ; + mselect ; + proj = + (fun (Manager_operation_result + { balance_updates = bus ; operation_result = r ; + internal_operation_results = rs }) -> + (bus, r, rs)) ; + inj = + (fun (bus, r, rs) -> + Manager_operation_result + { balance_updates = bus ; operation_result = r ; + internal_operation_results = rs }) ; + } + + let reveal_case = + make_manager_case + Operation.Encoding.reveal_case + Manager_result.reveal_case + (function + | Contents_and_result + (Manager_operation + { operation = Reveal _ ; _ } as op, res) -> + Some (op, res) + | _ -> None) + + let transaction_case = + make_manager_case + Operation.Encoding.transaction_case + Manager_result.transaction_case + (function + | Contents_and_result + (Manager_operation + { operation = Transaction _ ; _ } as op, res) -> + Some (op, res) + | _ -> None) + + let origination_case = + make_manager_case + Operation.Encoding.origination_case + Manager_result.origination_case + (function + | Contents_and_result + (Manager_operation + { operation = Origination _ ; _ } as op, res) -> + Some (op, res) + | _ -> None) + + let delegation_case = + make_manager_case + Operation.Encoding.delegation_case + Manager_result.delegation_case + (function + | Contents_and_result + (Manager_operation + { operation = Delegation _ ; _ } as op, res) -> + Some (op, res) + | _ -> None) + +end + +let contents_result_encoding = + let open Encoding in + let make (Case { op_case = Operation.Encoding.Case { tag ; name ; _ } ; + encoding ; mselect = _ ; select ; proj ; inj }) = + let proj x = + match select x with + | None -> None + | Some x -> Some (proj x) in + let inj x = Contents_result (inj x) in + tagged_case (Tag tag) name encoding proj inj in + def "operation.alpha.contents_result" @@ + union [ + make endorsement_case ; + make seed_nonce_revelation_case ; + make double_endorsement_evidence_case ; + make double_baking_evidence_case ; + make activate_account_case ; + make proposals_case ; + make ballot_case ; + make reveal_case ; + make transaction_case ; + make origination_case ; + make delegation_case ; + ] + +let contents_and_result_encoding = + let open Encoding in + let make + (Case { op_case = Operation.Encoding.Case { tag ; name ; encoding ; proj ; inj ; _ } ; + mselect ; encoding = meta_encoding ; proj = meta_proj ; inj = meta_inj ; _ }) = + let proj c = + match mselect c with + | Some (op, res) -> Some (proj op, meta_proj res) + | _ -> None in + let inj (op, res) = Contents_and_result (inj op, meta_inj res) in + let encoding = + merge_objs + encoding + (obj1 + (req "metadata" meta_encoding)) in + tagged_case (Tag tag) name encoding proj inj in + def "operation.alpha.operation_contents_and_result" @@ + union [ + make endorsement_case ; + make seed_nonce_revelation_case ; + make double_endorsement_evidence_case ; + make double_baking_evidence_case ; + make activate_account_case ; + make proposals_case ; + make ballot_case ; + make reveal_case ; + make transaction_case ; + make origination_case ; + make delegation_case ; + ] + +type 'kind contents_result_list = + | Single_result : 'kind contents_result -> 'kind contents_result_list + | Cons_result : + 'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list -> + (('kind * 'rest) Kind.manager ) contents_result_list + +type packed_contents_result_list = + Contents_result_list : 'kind contents_result_list -> packed_contents_result_list + +let contents_result_list_encoding = + let rec to_list = function + | Contents_result_list (Single_result o) -> [Contents_result o] + | Contents_result_list (Cons_result (o, os)) -> + Contents_result o :: to_list (Contents_result_list os) in + let rec of_list = function + | [] -> Pervasives.failwith "cannot decode empty operation result" + | [Contents_result o] -> Contents_result_list (Single_result o) + | (Contents_result o) :: os -> + let Contents_result_list os = of_list os in + match o, os with + | Manager_operation_result _, Single_result (Manager_operation_result _) -> + Contents_result_list (Cons_result (o, os)) + | Manager_operation_result _, Cons_result _ -> + Contents_result_list (Cons_result (o, os)) + | _ -> Pervasives.failwith "cannot decode ill-formed operation result" in + def "operation.alpha.contents_list_result" @@ + conv to_list of_list (list contents_result_encoding) + +type 'kind contents_and_result_list = + | Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list + | Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list + +type packed_contents_and_result_list = + | Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list + +let contents_and_result_list_encoding = + let rec to_list = function + | Contents_and_result_list (Single_and_result (op, res)) -> + [Contents_and_result (op, res)] + | Contents_and_result_list (Cons_and_result (op, res, rest)) -> + Contents_and_result (op, res) :: + to_list (Contents_and_result_list rest) in + let rec of_list = function + | [] -> Pervasives.failwith "cannot decode empty combined operation result" + | [Contents_and_result (op, res)] -> + Contents_and_result_list (Single_and_result (op, res)) + | (Contents_and_result (op, res)) :: rest -> + let Contents_and_result_list rest = of_list rest in + match op, rest with + | Manager_operation _, Single_and_result (Manager_operation _, _) -> + Contents_and_result_list (Cons_and_result (op, res, rest)) + | Manager_operation _, Cons_and_result (_, _, _) -> + Contents_and_result_list (Cons_and_result (op, res, rest)) + | _ -> Pervasives.failwith "cannot decode ill-formed combined operation result" in + conv to_list of_list (Variable.list contents_and_result_encoding) + +type 'kind operation_metadata = { + contents: 'kind contents_result_list ; +} + +type packed_operation_metadata = + | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata + | No_operation_metadata : packed_operation_metadata + +let operation_metadata_encoding = + def "operation.alpha.result" @@ + union [ + case (Tag 0) + ~title:"Operation_metadata" + contents_result_list_encoding + (function + | Operation_metadata { contents } -> + Some (Contents_result_list contents) + | _ -> None) + (fun (Contents_result_list contents) -> Operation_metadata { contents }) ; + case (Tag 1) + ~title:"No_operation_metadata" + empty + (function + | No_operation_metadata -> Some () + | _ -> None) + (fun () -> No_operation_metadata) ; + ] + +let kind_equal + : type kind kind2. kind contents -> kind2 contents_result -> (kind, kind2) eq option = + fun op res -> + match op, res with + | Endorsement _, Endorsement_result _ -> Some Eq + | Endorsement _, _ -> None + | Seed_nonce_revelation _, Seed_nonce_revelation_result _ -> Some Eq + | Seed_nonce_revelation _, _ -> None + | Double_endorsement_evidence _, Double_endorsement_evidence_result _ -> Some Eq + | Double_endorsement_evidence _, _ -> None + | Double_baking_evidence _, Double_baking_evidence_result _ -> Some Eq + | Double_baking_evidence _, _ -> None + | Activate_account _, Activate_account_result _ -> Some Eq + | Activate_account _, _ -> None + | Proposals _, Proposals_result -> Some Eq + | Proposals _, _ -> None + | Ballot _, Ballot_result -> Some Eq + | Ballot _, _ -> None + | Manager_operation + { operation = Reveal _ ; _ }, + Manager_operation_result + { operation_result = Applied (Reveal_result _); _ } -> Some Eq + | Manager_operation + { operation = Reveal _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Reveal_result _, _) ; _ } -> Some Eq + | Manager_operation + { operation = Reveal _ ; _ }, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Reveal_manager_kind, _); _ } -> Some Eq + | Manager_operation + { operation = Reveal _ ; _ }, + Manager_operation_result + { operation_result = + Skipped (Alpha_context.Kind.Reveal_manager_kind); _ } -> Some Eq + | Manager_operation { operation = Reveal _ ; _ }, _ -> None + | Manager_operation + { operation = Transaction _ ; _ }, + Manager_operation_result + { operation_result = Applied (Transaction_result _); _ } -> Some Eq + | Manager_operation + { operation = Transaction _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Transaction_result _, _); _ } -> Some Eq + | Manager_operation + { operation = Transaction _ ; _ }, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Transaction_manager_kind, _); _ } -> Some Eq + | Manager_operation + { operation = Transaction _ ; _ }, + Manager_operation_result + { operation_result = + Skipped (Alpha_context.Kind.Transaction_manager_kind); _ } -> Some Eq + | Manager_operation { operation = Transaction _ ; _ }, _ -> None + | Manager_operation + { operation = Origination _ ; _ }, + Manager_operation_result + { operation_result = Applied (Origination_result _); _ } -> Some Eq + | Manager_operation + { operation = Origination _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Origination_result _, _); _ } -> Some Eq + | Manager_operation + { operation = Origination _ ; _ }, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Origination_manager_kind, _); _ } -> Some Eq + | Manager_operation + { operation = Origination _ ; _ }, + Manager_operation_result + { operation_result = + Skipped (Alpha_context.Kind.Origination_manager_kind); _ } -> Some Eq + | Manager_operation { operation = Origination _ ; _ }, _ -> None + | Manager_operation + { operation = Delegation _ ; _ }, + Manager_operation_result + { operation_result = Applied (Delegation_result _) ; _ } -> Some Eq + | Manager_operation + { operation = Delegation _ ; _ }, + Manager_operation_result + { operation_result = Backtracked (Delegation_result _, _) ; _ } -> Some Eq + | Manager_operation + { operation = Delegation _ ; _ }, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Delegation_manager_kind, _); _ } -> Some Eq + | Manager_operation + { operation = Delegation _ ; _ }, + Manager_operation_result + { operation_result = + Skipped (Alpha_context.Kind.Delegation_manager_kind); _ } -> Some Eq + | Manager_operation { operation = Delegation _ ; _ }, _ -> None + +let rec kind_equal_list + : type kind kind2. kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option = + fun contents res -> + match contents, res with + | Single op, Single_result res -> begin + match kind_equal op res with + | None -> None + | Some Eq -> Some Eq + end + | Cons (op, ops), Cons_result (res, ress) -> begin + match kind_equal op res with + | None -> None + | Some Eq -> + match kind_equal_list ops ress with + | None -> None + | Some Eq -> Some Eq + end + | _ -> None + +let rec pack_contents_list : + type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list = + fun contents res -> begin + match contents, res with + | Single op, Single_result res -> Single_and_result (op, res) + | Cons (op, ops), Cons_result (res, ress) -> + Cons_and_result (op, res, pack_contents_list ops ress) + | Single (Manager_operation _), + Cons_result (Manager_operation_result _, Single_result _) -> . + | Cons (_, _), + Single_result (Manager_operation_result + { operation_result = Failed _ ; _}) -> . + | Cons (_, _), + Single_result (Manager_operation_result + { operation_result = Skipped _ ; _}) -> . + | Cons (_, _), + Single_result (Manager_operation_result + { operation_result = Applied _ ; _}) -> . + | Cons (_, _), + Single_result (Manager_operation_result + { operation_result = Backtracked _ ; _}) -> . + | Single _, Cons_result _ -> . + end + +let rec unpack_contents_list : + type kind. kind contents_and_result_list -> + (kind contents_list * kind contents_result_list) = + function + | Single_and_result (op, res) -> Single op, Single_result res + | Cons_and_result (op, res, rest) -> + let ops, ress = unpack_contents_list rest in + Cons (op, ops), Cons_result (res, ress) + +let rec to_list = function + | Contents_result_list (Single_result o) -> [Contents_result o] + | Contents_result_list (Cons_result (o, os)) -> + Contents_result o :: to_list (Contents_result_list os) + +let rec of_list = function + | [] -> assert false + | [Contents_result o] -> Contents_result_list (Single_result o) + | (Contents_result o) :: os -> + let Contents_result_list os = of_list os in + match o, os with + | Manager_operation_result _, Single_result (Manager_operation_result _) -> + Contents_result_list (Cons_result (o, os)) + | Manager_operation_result _, Cons_result _ -> + Contents_result_list (Cons_result (o, os)) + | _ -> + Pervasives.failwith "Operation result list of length > 1 \ + should only contains manager operations result." + +let operation_data_and_metadata_encoding = + def "operation.alpha.operation_with_metadata" @@ + union [ + case (Tag 0) + ~title:"Operation_with_metadata" + (obj2 + (req "contents" (dynamic_size contents_and_result_list_encoding)) + (opt "signature" Signature.encoding)) + (function + | (Operation_data _, No_operation_metadata) -> None + | (Operation_data op, Operation_metadata res) -> + match kind_equal_list op.contents res.contents with + | None -> Pervasives.failwith "cannot decode inconsistent combined operation result" + | Some Eq -> + Some + (Contents_and_result_list + (pack_contents_list op.contents res.contents), + op.signature)) + (fun (Contents_and_result_list contents, signature) -> + let op_contents, res_contents = unpack_contents_list contents in + (Operation_data { contents = op_contents ; signature }, + Operation_metadata { contents = res_contents })) ; + case (Tag 1) + ~title:"Operation_without_metadata" + (obj2 + (req "contents" (dynamic_size Operation.contents_list_encoding)) + (opt "signature" Signature.encoding)) + (function + | (Operation_data op, No_operation_metadata) -> + Some (Contents_list op.contents, op.signature) + | (Operation_data _, Operation_metadata _) -> + None) + (fun (Contents_list contents, signature) -> + (Operation_data { contents ; signature }, No_operation_metadata)) + ] + +type block_metadata = { + baker: Signature.Public_key_hash.t ; + level: Level.t ; + voting_period_kind: Voting_period.kind ; + nonce_hash: Nonce_hash.t option ; + consumed_gas: Z.t ; + deactivated: Signature.Public_key_hash.t list ; + balance_updates: Delegate.balance_updates ; +} + +let block_metadata_encoding = + let open Data_encoding in + def "block_header.alpha.metadata" @@ + conv + (fun { baker ; level ; voting_period_kind ; nonce_hash ; + consumed_gas ; deactivated ; balance_updates } -> + ( baker, level, voting_period_kind, nonce_hash, + consumed_gas, deactivated, balance_updates )) + (fun ( baker, level, voting_period_kind, nonce_hash, + consumed_gas, deactivated, balance_updates ) -> + { baker ; level ; voting_period_kind ; nonce_hash ; + consumed_gas ; deactivated ; balance_updates }) + (obj7 + (req "baker" Signature.Public_key_hash.encoding) + (req "level" Level.encoding) + (req "voting_period_kind" Voting_period.kind_encoding) + (req "nonce_hash" (option Nonce_hash.encoding)) + (req "consumed_gas" (check_size 10 n)) + (req "deactivated" (list Signature.Public_key_hash.encoding)) + (req "balance_updates" Delegate.balance_updates_encoding)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli new file mode 100644 index 000000000..b4505f502 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli @@ -0,0 +1,167 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Result of applying an operation, can be used for experimenting + with protocol updates, by clients to print out a summary of the + operation at pre-injection simulation and at confirmation time, + and by block explorers. *) + +open Alpha_context + +(** Result of applying a {!Operation.t}. Follows the same structure. *) +type 'kind operation_metadata = { + contents: 'kind contents_result_list ; +} + +and packed_operation_metadata = + | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata + | No_operation_metadata : packed_operation_metadata + +(** Result of applying a {!Operation.contents_list}. Follows the same structure. *) +and 'kind contents_result_list = + | Single_result : 'kind contents_result -> 'kind contents_result_list + | Cons_result : + 'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list -> + (('kind * 'rest) Kind.manager ) contents_result_list + +and packed_contents_result_list = + | Contents_result_list : 'kind contents_result_list -> packed_contents_result_list + +(** Result of applying an {!Operation.contents}. Follows the same structure. *) +and 'kind contents_result = + | Endorsement_result : + { balance_updates : Delegate.balance_updates ; + delegate : Signature.Public_key_hash.t ; + slots: int list ; + } -> Kind.endorsement contents_result + | Seed_nonce_revelation_result : + Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result + | Double_endorsement_evidence_result : + Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result + | Double_baking_evidence_result : + Delegate.balance_updates -> Kind.double_baking_evidence contents_result + | Activate_account_result : + Delegate.balance_updates -> Kind.activate_account contents_result + | Proposals_result : Kind.proposals contents_result + | Ballot_result : Kind.ballot contents_result + | Manager_operation_result : + { balance_updates : Delegate.balance_updates ; + operation_result : 'kind manager_operation_result ; + internal_operation_results : packed_internal_operation_result list ; + } -> 'kind Kind.manager contents_result + +and packed_contents_result = + | Contents_result : 'kind contents_result -> packed_contents_result + +(** The result of an operation in the queue. [Skipped] ones should + always be at the tail, and after a single [Failed]. *) +and 'kind manager_operation_result = + | Applied of 'kind successful_manager_operation_result + | Backtracked of 'kind successful_manager_operation_result * error list option + | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result + | Skipped : 'kind Kind.manager -> 'kind manager_operation_result + +(** Result of applying a {!manager_operation_content}, either internal + or external. *) +and _ successful_manager_operation_result = + | Reveal_result : + { consumed_gas : Z.t + } -> Kind.reveal successful_manager_operation_result + | Transaction_result : + { storage : Script.expr option ; + big_map_diff : Contract.big_map_diff option ; + balance_updates : Delegate.balance_updates ; + originated_contracts : Contract.t list ; + consumed_gas : Z.t ; + storage_size : Z.t ; + paid_storage_size_diff : Z.t ; + allocated_destination_contract : bool ; + } -> Kind.transaction successful_manager_operation_result + | Origination_result : + { balance_updates : Delegate.balance_updates ; + originated_contracts : Contract.t list ; + consumed_gas : Z.t ; + storage_size : Z.t ; + paid_storage_size_diff : Z.t ; + } -> Kind.origination successful_manager_operation_result + | Delegation_result : + { consumed_gas : Z.t + } -> Kind.delegation successful_manager_operation_result + +and packed_successful_manager_operation_result = + | Successful_manager_result : + 'kind successful_manager_operation_result -> packed_successful_manager_operation_result + +and packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation * 'kind manager_operation_result -> + packed_internal_operation_result + +(** Serializer for {!packed_operation_result}. *) +val operation_metadata_encoding : packed_operation_metadata Data_encoding.t + +val operation_data_and_metadata_encoding + : (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t + + + +type 'kind contents_and_result_list = + | Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list + | Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list + +type packed_contents_and_result_list = + | Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list + +val contents_and_result_list_encoding : + packed_contents_and_result_list Data_encoding.t + +val pack_contents_list : + 'kind contents_list -> 'kind contents_result_list -> + 'kind contents_and_result_list + +val unpack_contents_list : + 'kind contents_and_result_list -> + 'kind contents_list * 'kind contents_result_list + +val to_list : + packed_contents_result_list -> packed_contents_result list + +val of_list : + packed_contents_result list -> packed_contents_result_list + +type ('a, 'b) eq = Eq : ('a, 'a) eq +val kind_equal_list : + 'kind contents_list -> 'kind2 contents_result_list -> ('kind, 'kind2) eq option + +type block_metadata = { + baker: Signature.Public_key_hash.t ; + level: Level.t ; + voting_period_kind: Voting_period.kind ; + nonce_hash: Nonce_hash.t option ; + consumed_gas: Z.t ; + deactivated: Signature.Public_key_hash.t list ; + balance_updates: Delegate.balance_updates ; +} +val block_metadata_encoding: block_metadata Data_encoding.encoding diff --git a/vendors/ligo-utils/tezos-protocol-alpha/baking.ml b/vendors/ligo-utils/tezos-protocol-alpha/baking.ml new file mode 100644 index 000000000..d8d222c20 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/baking.ml @@ -0,0 +1,296 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + + +open Alpha_context +open Misc + +type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) +type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *) +type error += Unexpected_endorsement (* `Permanent *) +type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *) +type error += Invalid_signature (* `Permanent *) +type error += Invalid_stamp (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"baking.timestamp_too_early" + ~title:"Block forged too early" + ~description:"The block timestamp is before the first slot \ + for this baker at this level" + ~pp:(fun ppf (r, p) -> + Format.fprintf ppf "Block forged too early (%a is before %a)" + Time.pp_hum p Time.pp_hum r) + Data_encoding.(obj2 + (req "minimum" Time.encoding) + (req "provided" Time.encoding)) + (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None) + (fun (r, p) -> Timestamp_too_early (r, p)) ; + register_error_kind + `Permanent + ~id:"baking.invalid_fitness_gap" + ~title:"Invalid fitness gap" + ~description:"The gap of fitness is out of bounds" + ~pp:(fun ppf (m, g) -> + Format.fprintf ppf + "The gap of fitness %Ld is not between 0 and %Ld" g m) + Data_encoding.(obj2 + (req "maximum" int64) + (req "provided" int64)) + (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None) + (fun (m, g) -> Invalid_fitness_gap (m, g)) ; + register_error_kind + `Permanent + ~id:"baking.invalid_block_signature" + ~title:"Invalid block signature" + ~description: + "A block was not signed with the expected private key." + ~pp:(fun ppf (block, pkh) -> + Format.fprintf ppf "Invalid signature for block %a. Expected: %a." + Block_hash.pp_short block + Signature.Public_key_hash.pp_short pkh) + Data_encoding.(obj2 + (req "block" Block_hash.encoding) + (req "expected" Signature.Public_key_hash.encoding)) + (function Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None) + (fun (block, pkh) -> Invalid_block_signature (block, pkh)); + register_error_kind + `Permanent + ~id:"baking.invalid_signature" + ~title:"Invalid block signature" + ~description:"The block's signature is invalid" + ~pp:(fun ppf () -> + Format.fprintf ppf "Invalid block signature") + Data_encoding.empty + (function Invalid_signature -> Some () | _ -> None) + (fun () -> Invalid_signature) ; + register_error_kind + `Permanent + ~id:"baking.insufficient_proof_of_work" + ~title:"Insufficient block proof-of-work stamp" + ~description:"The block's proof-of-work stamp is insufficient" + ~pp:(fun ppf () -> + Format.fprintf ppf "Insufficient proof-of-work stamp") + Data_encoding.empty + (function Invalid_stamp -> Some () | _ -> None) + (fun () -> Invalid_stamp) ; + register_error_kind + `Permanent + ~id:"baking.unexpected_endorsement" + ~title:"Endorsement from unexpected delegate" + ~description:"The operation is signed by a delegate without endorsement rights." + ~pp:(fun ppf () -> + Format.fprintf ppf + "The endorsement is signed by a delegate without endorsement rights.") + Data_encoding.unit + (function Unexpected_endorsement -> Some () | _ -> None) + (fun () -> Unexpected_endorsement) + +let minimal_time c priority pred_timestamp = + let priority = Int32.of_int priority in + let rec cumsum_time_between_blocks acc durations p = + if Compare.Int32.(<=) p 0l then + ok acc + else match durations with + | [] -> cumsum_time_between_blocks acc [ Period.one_minute ] p + | [ last ] -> + Period.mult p last >>? fun period -> + Timestamp.(acc +? period) + | first :: durations -> + Timestamp.(acc +? first) >>? fun acc -> + let p = Int32.pred p in + cumsum_time_between_blocks acc durations p in + Lwt.return + (cumsum_time_between_blocks + pred_timestamp (Constants.time_between_blocks c) (Int32.succ priority)) + +let earlier_predecessor_timestamp ctxt level = + let current = Level.current ctxt in + let current_timestamp = Timestamp.current ctxt in + let gap = Level.diff level current in + let step = List.hd (Constants.time_between_blocks ctxt) in + if Compare.Int32.(gap < 1l) then + failwith "Baking.earlier_block_timestamp: past block." + else + Lwt.return (Period.mult (Int32.pred gap) step) >>=? fun delay -> + Lwt.return Timestamp.(current_timestamp +? delay) >>=? fun result -> + return result + +let check_timestamp c priority pred_timestamp = + minimal_time c priority pred_timestamp >>=? fun minimal_time -> + let timestamp = Alpha_context.Timestamp.current c in + fail_unless Timestamp.(minimal_time <= timestamp) + (Timestamp_too_early (minimal_time, timestamp)) + +let check_baking_rights c { Block_header.priority ; _ } + pred_timestamp = + let level = Level.current c in + Roll.baking_rights_owner c level ~priority >>=? fun delegate -> + check_timestamp c priority pred_timestamp >>=? fun () -> + return delegate + +type error += Incorrect_priority (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"incorrect_priority" + ~title:"Incorrect priority" + ~description:"Block priority must be non-negative." + ~pp:(fun ppf () -> + Format.fprintf ppf "The block priority must be non-negative.") + Data_encoding.unit + (function Incorrect_priority -> Some () | _ -> None) + (fun () -> Incorrect_priority) + +let endorsement_reward ctxt ~block_priority:prio n = + if Compare.Int.(prio >= 0) + then + Lwt.return + Tez.(Constants.endorsement_reward ctxt /? (Int64.(succ (of_int prio)))) >>=? fun tez -> + Lwt.return Tez.(tez *? Int64.of_int n) + else fail Incorrect_priority + +let baking_priorities c level = + let rec f priority = + Roll.baking_rights_owner c level ~priority >>=? fun delegate -> + return (LCons (delegate, (fun () -> f (succ priority)))) + in + f 0 + +let endorsement_rights c level = + fold_left_s + (fun acc slot -> + Roll.endorsement_rights_owner c level ~slot >>=? fun pk -> + let pkh = Signature.Public_key.hash pk in + let right = + match Signature.Public_key_hash.Map.find_opt pkh acc with + | None -> (pk, [slot], false) + | Some (pk, slots, used) -> (pk, slot :: slots, used) in + return (Signature.Public_key_hash.Map.add pkh right acc)) + Signature.Public_key_hash.Map.empty + (0 --> (Constants.endorsers_per_block c - 1)) + +let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t) = + let current_level = Level.current ctxt in + let Single (Endorsement { level ; _ }) = op.protocol_data.contents in + begin + if Raw_level.(succ level = current_level.level) then + return (Alpha_context.allowed_endorsements ctxt) + else + endorsement_rights ctxt (Level.from_raw ctxt level) + end >>=? fun endorsements -> + match + Signature.Public_key_hash.Map.fold (* no find_first *) + (fun pkh (pk, slots, used) acc -> + match Operation.check_signature_sync pk chain_id op with + | Error _ -> acc + | Ok () -> Some (pkh, slots, used)) + endorsements None + with + | None -> fail Unexpected_endorsement + | Some v -> return v + +let select_delegate delegate delegate_list max_priority = + let rec loop acc l n = + if Compare.Int.(n >= max_priority) + then return (List.rev acc) + else + let LCons (pk, t) = l in + let acc = + if Signature.Public_key_hash.equal delegate (Signature.Public_key.hash pk) + then n :: acc + else acc in + t () >>=? fun t -> + loop acc t (succ n) + in + loop [] delegate_list 0 + +let first_baking_priorities + ctxt + ?(max_priority = 32) + delegate level = + baking_priorities ctxt level >>=? fun delegate_list -> + select_delegate delegate delegate_list max_priority + +let check_hash hash stamp_threshold = + let bytes = Block_hash.to_bytes hash in + let word = MBytes.get_int64 bytes 0 in + Compare.Uint64.(word <= stamp_threshold) + +let check_header_proof_of_work_stamp shell contents stamp_threshold = + let hash = + Block_header.hash + { shell ; protocol_data = { contents ; signature = Signature.zero } } in + check_hash hash stamp_threshold + +let check_proof_of_work_stamp ctxt block = + let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in + if check_header_proof_of_work_stamp + block.Block_header.shell + block.protocol_data.contents + proof_of_work_threshold then + return_unit + else + fail Invalid_stamp + +let check_signature block chain_id key = + let check_signature key + { Block_header.shell ; protocol_data = { contents ; signature } } = + let unsigned_header = + Data_encoding.Binary.to_bytes_exn + Block_header.unsigned_encoding + (shell, contents) in + Signature.check ~watermark:(Block_header chain_id) key signature unsigned_header in + if check_signature key block then + return_unit + else + fail (Invalid_block_signature (Block_header.hash block, + Signature.Public_key.hash key)) + +let max_fitness_gap ctxt = + let slots = Int64.of_int (Constants.endorsers_per_block ctxt + 1) in + Int64.add slots 1L + +let check_fitness_gap ctxt (block : Block_header.t) = + let current_fitness = Fitness.current ctxt in + Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness -> + let gap = Int64.sub announced_fitness current_fitness in + if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then + fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap)) + else + return_unit + +let last_of_a_cycle ctxt l = + Compare.Int32.(Int32.succ l.Level.cycle_position = + Constants.blocks_per_cycle ctxt) + +let dawn_of_a_new_cycle ctxt = + let level = Level.current ctxt in + if last_of_a_cycle ctxt level then + return_some level.cycle + else + return_none diff --git a/vendors/ligo-utils/tezos-protocol-alpha/baking.mli b/vendors/ligo-utils/tezos-protocol-alpha/baking.mli new file mode 100644 index 000000000..52c78f74b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/baking.mli @@ -0,0 +1,108 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + + +open Alpha_context +open Misc + +type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) +type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *) +type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *) +type error += Unexpected_endorsement +type error += Invalid_signature (* `Permanent *) +type error += Invalid_stamp (* `Permanent *) + +(** [minimal_time ctxt priority pred_block_time] returns the minimal + time, given the predecessor block timestamp [pred_block_time], + after which a baker with priority [priority] is allowed to + bake. Fail with [Invalid_time_between_blocks_constant] if the minimal + time cannot be computed. *) +val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t + +(** [check_baking_rights ctxt block pred_timestamp] verifies that: + * the contract that owned the roll at cycle start has the block signer as delegate. + * the timestamp is coherent with the announced slot. +*) +val check_baking_rights: + context -> Block_header.contents -> Time.t -> + public_key tzresult Lwt.t + +(** For a given level computes who has the right to + include an endorsement in the next block. + The result can be stored in Alpha_context.allowed_endorsements *) +val endorsement_rights: + context -> + Level.t -> + (public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t + +(** Check that the operation was signed by a delegate allowed + to endorse at the level specified by the endorsement. *) +val check_endorsement_rights: + context -> Chain_id.t -> Kind.endorsement Operation.t -> + (public_key_hash * int list * bool) tzresult Lwt.t + +(** Returns the endorsement reward calculated w.r.t a given priority. *) +val endorsement_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t + +(** [baking_priorities ctxt level] is the lazy list of contract's + public key hashes that are allowed to bake for [level]. *) +val baking_priorities: + context -> Level.t -> public_key lazy_list + +(** [first_baking_priorities ctxt ?max_priority contract_hash level] + is a list of priorities of max [?max_priority] elements, where the + delegate of [contract_hash] is allowed to bake for [level]. If + [?max_priority] is [None], a sensible number of priorities is + returned. *) +val first_baking_priorities: + context -> + ?max_priority:int -> + public_key_hash -> + Level.t -> + int list tzresult Lwt.t + +(** [check_signature ctxt chain_id block id] check if the block is + signed with the given key, and belongs to the given [chain_id] *) +val check_signature: Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t + +(** Checks if the header that would be built from the given components + is valid for the given diffculty. The signature is not passed as it + is does not impact the proof-of-work stamp. The stamp is checked on + the hash of a block header whose signature has been zeroed-out. *) +val check_header_proof_of_work_stamp: + Block_header.shell_header -> Block_header.contents -> int64 -> bool + +(** verify if the proof of work stamp is valid *) +val check_proof_of_work_stamp: + context -> Block_header.t -> unit tzresult Lwt.t + +(** check if the gap between the fitness of the current context + and the given block is within the protocol parameters *) +val check_fitness_gap: + context -> Block_header.t -> unit tzresult Lwt.t + +val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t + +val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml new file mode 100644 index 000000000..b18824748 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module H = Blake2B.Make(Base58)(struct + let name = "Blinded public key hash" + let title = "A blinded public key hash" + let b58check_prefix = "\001\002\049\223" + let size = Some Ed25519.Public_key_hash.size + end) + +include H + +let () = + Base58.check_encoded_prefix b58check_encoding "btz1" 37 + +let of_ed25519_pkh activation_code pkh = + hash_bytes ~key:activation_code [ Ed25519.Public_key_hash.to_bytes pkh ] + +type activation_code = MBytes.t + +let activation_code_size = Ed25519.Public_key_hash.size +let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size + +let activation_code_of_hex h = + if Compare.Int.(String.length h <> activation_code_size * 2) then + invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ; + MBytes.of_hex (`Hex h) + +module Index = H diff --git a/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli new file mode 100644 index 000000000..c9306c867 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include S.HASH + +val encoding : t Data_encoding.t +val rpc_arg : t RPC_arg.t + +type activation_code +val activation_code_encoding : activation_code Data_encoding.t + +val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t + +val activation_code_of_hex : string -> activation_code + +module Index : Storage_description.INDEX with type t = t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml new file mode 100644 index 000000000..7fb78dedf --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml @@ -0,0 +1,138 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Block header *) + +type t = { + shell: Block_header.shell_header ; + protocol_data: protocol_data ; +} + +and protocol_data = { + contents: contents ; + signature: Signature.t ; +} + +and contents = { + priority: int ; + seed_nonce_hash: Nonce_hash.t option ; + proof_of_work_nonce: MBytes.t ; +} + +type block_header = t + +type raw = Block_header.t +type shell_header = Block_header.shell_header + +let raw_encoding = Block_header.encoding +let shell_header_encoding = Block_header.shell_header_encoding + +let contents_encoding = + let open Data_encoding in + def "block_header.alpha.unsigned_contents" @@ + conv + (fun { priority ; seed_nonce_hash ; proof_of_work_nonce } -> + (priority, proof_of_work_nonce, seed_nonce_hash)) + (fun (priority, proof_of_work_nonce, seed_nonce_hash) -> + { priority ; seed_nonce_hash ; proof_of_work_nonce }) + (obj3 + (req "priority" uint16) + (req "proof_of_work_nonce" + (Fixed.bytes Constants_repr.proof_of_work_nonce_size)) + (opt "seed_nonce_hash" Nonce_hash.encoding)) + +let protocol_data_encoding = + let open Data_encoding in + def "block_header.alpha.signed_contents" @@ + conv + (fun { contents ; signature } -> (contents, signature)) + (fun (contents, signature) -> { contents ; signature }) + (merge_objs + contents_encoding + (obj1 (req "signature" Signature.encoding))) + +let raw { shell ; protocol_data ; } = + let protocol_data = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + protocol_data in + { Block_header.shell ; protocol_data } + +let unsigned_encoding = + let open Data_encoding in + merge_objs + Block_header.shell_header_encoding + contents_encoding + +let encoding = + let open Data_encoding in + def "block_header.alpha.full_header" @@ + conv + (fun { shell ; protocol_data } -> + (shell, protocol_data)) + (fun (shell, protocol_data) -> + { shell ; protocol_data }) + (merge_objs + Block_header.shell_header_encoding + protocol_data_encoding) + +(** Constants *) + +let max_header_length = + let fake_shell = { + Block_header.level = 0l ; + proto_level = 0 ; + predecessor = Block_hash.zero ; + timestamp = Time.of_seconds 0L ; + validation_passes = 0 ; + operations_hash = Operation_list_list_hash.zero ; + fitness = Fitness_repr.from_int64 0L ; + context = Context_hash.zero ; + } + and fake_contents = + { priority = 0 ; + proof_of_work_nonce = + MBytes.create Constants_repr.proof_of_work_nonce_size ; + seed_nonce_hash = Some Nonce_hash.zero + } in + Data_encoding.Binary.length + encoding + { shell = fake_shell ; + protocol_data = { + contents = fake_contents ; + signature = Signature.zero ; + } + } + +(** Header parsing entry point *) + +let hash_raw = Block_header.hash +let hash { shell ; protocol_data } = + Block_header.hash + { shell ; + protocol_data = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + protocol_data } diff --git a/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli new file mode 100644 index 000000000..9ce44a3d5 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli @@ -0,0 +1,60 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + shell: Block_header.shell_header ; + protocol_data: protocol_data ; +} + +and protocol_data = { + contents: contents ; + signature: Signature.t ; +} + +and contents = { + priority: int ; + seed_nonce_hash: Nonce_hash.t option ; + proof_of_work_nonce: MBytes.t ; +} + +type block_header = t + +type raw = Block_header.t +type shell_header = Block_header.shell_header + +val raw: block_header -> raw + +val encoding: block_header Data_encoding.encoding +val raw_encoding: raw Data_encoding.t +val contents_encoding: contents Data_encoding.t +val unsigned_encoding: (Block_header.shell_header * contents) Data_encoding.t +val protocol_data_encoding: protocol_data Data_encoding.encoding +val shell_header_encoding: shell_header Data_encoding.encoding + +val max_header_length: int +(** The maximum size of block headers in bytes *) + +val hash: block_header -> Block_hash.t +val hash_raw: raw -> Block_hash.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml new file mode 100644 index 000000000..50d17dfff --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml @@ -0,0 +1,128 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Misc + +let init_account ctxt + ({ public_key_hash ; public_key ; amount }: Parameters_repr.bootstrap_account) = + let contract = Contract_repr.implicit_contract public_key_hash in + Contract_storage.credit ctxt contract amount >>=? fun ctxt -> + match public_key with + | Some public_key -> + Contract_storage.reveal_manager_key ctxt contract public_key >>=? fun ctxt -> + Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt -> + return ctxt + | None -> return ctxt + +let init_contract ~typecheck ctxt + ({ delegate ; amount ; script }: Parameters_repr.bootstrap_contract) = + Contract_storage.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + typecheck ctxt script >>=? fun (script, ctxt) -> + Contract_storage.originate ctxt contract + ~balance:amount + ~prepaid_bootstrap_storage:true + ~manager:Signature.Public_key_hash.zero + ~script + ~delegate:(Some delegate) + ~spendable:false + ~delegatable:false >>=? fun ctxt -> + return ctxt + +let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts = + let nonce = + Operation_hash.hash_bytes + [ MBytes.of_string "Un festival de GADT." ] in + let ctxt = Raw_context.init_origination_nonce ctxt nonce in + fold_left_s init_account ctxt accounts >>=? fun ctxt -> + fold_left_s (init_contract ~typecheck) ctxt contracts >>=? fun ctxt -> + begin + match no_reward_cycles with + | None -> return ctxt + | Some cycles -> + (* Store pending ramp ups. *) + let constants = Raw_context.constants ctxt in + (* Start without reward *) + Raw_context.patch_constants ctxt + (fun c -> + { c with + block_reward = Tez_repr.zero ; + endorsement_reward = Tez_repr.zero }) >>= fun ctxt -> + (* Store the final reward. *) + Storage.Ramp_up.Rewards.init ctxt + (Cycle_repr.of_int32_exn (Int32.of_int cycles)) + (constants.block_reward, + constants.endorsement_reward) + end >>=? fun ctxt -> + match ramp_up_cycles with + | None -> return ctxt + | Some cycles -> + (* Store pending ramp ups. *) + let constants = Raw_context.constants ctxt in + Lwt.return Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles) >>=? fun block_step -> + Lwt.return Tez_repr.(constants.endorsement_security_deposit /? Int64.of_int cycles) >>=? fun endorsement_step -> + (* Start without security_deposit *) + Raw_context.patch_constants ctxt + (fun c -> + { c with + block_security_deposit = Tez_repr.zero ; + endorsement_security_deposit = Tez_repr.zero }) >>= fun ctxt -> + fold_left_s + (fun ctxt cycle -> + Lwt.return Tez_repr.(block_step *? Int64.of_int cycle) >>=? fun block_security_deposit -> + Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle) >>=? fun endorsement_security_deposit -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in + Storage.Ramp_up.Security_deposits.init ctxt cycle + (block_security_deposit, endorsement_security_deposit)) + ctxt + (1 --> (cycles - 1)) >>=? fun ctxt -> + (* Store the final security deposits. *) + Storage.Ramp_up.Security_deposits.init ctxt + (Cycle_repr.of_int32_exn (Int32.of_int cycles)) + (constants.block_security_deposit, + constants.endorsement_security_deposit) >>=? fun ctxt -> + return ctxt + +let cycle_end ctxt last_cycle = + let next_cycle = Cycle_repr.succ last_cycle in + begin + Storage.Ramp_up.Rewards.get_option ctxt next_cycle >>=? function + | None -> return ctxt + | Some (block_reward, endorsement_reward) -> + Storage.Ramp_up.Rewards.delete ctxt next_cycle >>=? fun ctxt -> + Raw_context.patch_constants ctxt + (fun c -> + { c with block_reward ; + endorsement_reward }) >>= fun ctxt -> + return ctxt + end >>=? fun ctxt -> + Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle >>=? function + | None -> return ctxt + | Some (block_security_deposit, endorsement_security_deposit) -> + Storage.Ramp_up.Security_deposits.delete ctxt next_cycle >>=? fun ctxt -> + Raw_context.patch_constants ctxt + (fun c -> + { c with block_security_deposit ; + endorsement_security_deposit }) >>= fun ctxt -> + return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli new file mode 100644 index 000000000..b489228a4 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val init: + Raw_context.t -> + typecheck:(Raw_context.t -> Script_repr.t -> + ((Script_repr.t * Contract_storage.big_map_diff option) * Raw_context.t) + tzresult Lwt.t) -> + ?ramp_up_cycles:int -> + ?no_reward_cycles:int -> + Parameters_repr.bootstrap_account list -> + Parameters_repr.bootstrap_contract list -> + Raw_context.t tzresult Lwt.t + +val cycle_end: + Raw_context.t -> + Cycle_repr.t -> + Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml new file mode 100644 index 000000000..89b9272de --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + blinded_public_key_hash : Blinded_public_key_hash.t ; + amount : Tez_repr.t +} + +let encoding = + let open Data_encoding in + conv + (fun { blinded_public_key_hash ; amount } -> + ( blinded_public_key_hash, amount )) + (fun ( blinded_public_key_hash, amount) -> + { blinded_public_key_hash ; amount }) + (tup2 + Blinded_public_key_hash.encoding + Tez_repr.encoding) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli new file mode 100644 index 000000000..4bd74810a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli @@ -0,0 +1,31 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + blinded_public_key_hash : Blinded_public_key_hash.t ; + amount : Tez_repr.t ; +} + +val encoding : t Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml new file mode 100644 index 000000000..a8680b976 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let get_opt = Storage.Commitments.get_option +let delete = Storage.Commitments.delete + +let init ctxt commitments = + let init_commitment ctxt Commitment_repr.{ blinded_public_key_hash ; amount } = + Storage.Commitments.init ctxt blinded_public_key_hash amount in + fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> + return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli new file mode 100644 index 000000000..1e5be6dc5 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli @@ -0,0 +1,37 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val init: + Raw_context.t -> + Commitment_repr.t list -> + Raw_context.t tzresult Lwt.t + +val get_opt: + Raw_context.t -> Blinded_public_key_hash.t -> + Tez_repr.t option tzresult Lwt.t + +val delete: + Raw_context.t -> Blinded_public_key_hash.t -> + Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml new file mode 100644 index 000000000..7ab55b468 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml @@ -0,0 +1,236 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let version_number = "\000" +let proof_of_work_nonce_size = 8 +let nonce_length = 32 +let max_revelations_per_block = 32 +let max_proposals_per_delegate = 20 +let max_operation_data_length = 16 * 1024 (* 16kB *) + +type fixed = { + proof_of_work_nonce_size : int ; + nonce_length : int ; + max_revelations_per_block : int ; + max_operation_data_length : int ; + max_proposals_per_delegate : int ; +} + +let fixed_encoding = + let open Data_encoding in + conv + (fun c -> + (c.proof_of_work_nonce_size, + c.nonce_length, + c.max_revelations_per_block, + c.max_operation_data_length, + c.max_proposals_per_delegate)) + (fun (proof_of_work_nonce_size, + nonce_length, + max_revelations_per_block, + max_operation_data_length, + max_proposals_per_delegate) -> + { proof_of_work_nonce_size ; + nonce_length ; + max_revelations_per_block ; + max_operation_data_length ; + max_proposals_per_delegate ; + } ) + (obj5 + (req "proof_of_work_nonce_size" uint8) + (req "nonce_length" uint8) + (req "max_revelations_per_block" uint8) + (req "max_operation_data_length" int31) + (req "max_proposals_per_delegate" uint8)) + +let fixed = { + proof_of_work_nonce_size ; + nonce_length ; + max_revelations_per_block ; + max_operation_data_length ; + max_proposals_per_delegate ; +} + +type parametric = { + preserved_cycles: int ; + blocks_per_cycle: int32 ; + blocks_per_commitment: int32 ; + blocks_per_roll_snapshot: int32 ; + blocks_per_voting_period: int32 ; + time_between_blocks: Period_repr.t list ; + endorsers_per_block: int ; + hard_gas_limit_per_operation: Z.t ; + hard_gas_limit_per_block: Z.t ; + proof_of_work_threshold: int64 ; + tokens_per_roll: Tez_repr.t ; + michelson_maximum_type_size: int; + seed_nonce_revelation_tip: Tez_repr.t ; + origination_size: int ; + block_security_deposit: Tez_repr.t ; + endorsement_security_deposit: Tez_repr.t ; + block_reward: Tez_repr.t ; + endorsement_reward: Tez_repr.t ; + cost_per_byte: Tez_repr.t ; + hard_storage_limit_per_operation: Z.t ; + test_chain_duration: int64 ; (* in seconds *) +} + +let default = { + preserved_cycles = 5 ; + blocks_per_cycle = 4096l ; + blocks_per_commitment = 32l ; + blocks_per_roll_snapshot = 256l ; + blocks_per_voting_period = 32768l ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ; + endorsers_per_block = 32 ; + hard_gas_limit_per_operation = Z.of_int 800_000 ; + hard_gas_limit_per_block = Z.of_int 8_000_000 ; + proof_of_work_threshold = + Int64.(sub (shift_left 1L 46) 1L) ; + tokens_per_roll = + Tez_repr.(mul_exn one 8_000) ; + michelson_maximum_type_size = 1000 ; + seed_nonce_revelation_tip = begin + match Tez_repr.(one /? 8L) with + | Ok c -> c + | Error _ -> assert false + end ; + origination_size = 257 ; + block_security_deposit = Tez_repr.(mul_exn one 512) ; + endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; + block_reward = Tez_repr.(mul_exn one 16) ; + endorsement_reward = Tez_repr.(mul_exn one 2) ; + hard_storage_limit_per_operation = Z.of_int 60_000 ; + cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; + test_chain_duration = Int64.mul 32768L 60L; +} + +let parametric_encoding = + let open Data_encoding in + conv + (fun c -> + (( c.preserved_cycles, + c.blocks_per_cycle, + c.blocks_per_commitment, + c.blocks_per_roll_snapshot, + c.blocks_per_voting_period, + c.time_between_blocks, + c.endorsers_per_block, + c.hard_gas_limit_per_operation, + c.hard_gas_limit_per_block), + ((c.proof_of_work_threshold, + c.tokens_per_roll, + c.michelson_maximum_type_size, + c.seed_nonce_revelation_tip, + c.origination_size, + c.block_security_deposit, + c.endorsement_security_deposit, + c.block_reward), + (c.endorsement_reward, + c.cost_per_byte, + c.hard_storage_limit_per_operation, + c.test_chain_duration))) ) + (fun (( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block), + ((proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward), + (endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration))) -> + { preserved_cycles ; + blocks_per_cycle ; + blocks_per_commitment ; + blocks_per_roll_snapshot ; + blocks_per_voting_period ; + time_between_blocks ; + endorsers_per_block ; + hard_gas_limit_per_operation ; + hard_gas_limit_per_block ; + proof_of_work_threshold ; + tokens_per_roll ; + michelson_maximum_type_size ; + seed_nonce_revelation_tip ; + origination_size ; + block_security_deposit ; + endorsement_security_deposit ; + block_reward ; + endorsement_reward ; + cost_per_byte ; + hard_storage_limit_per_operation ; + test_chain_duration ; + } ) + (merge_objs + (obj9 + (req "preserved_cycles" uint8) + (req "blocks_per_cycle" int32) + (req "blocks_per_commitment" int32) + (req "blocks_per_roll_snapshot" int32) + (req "blocks_per_voting_period" int32) + (req "time_between_blocks" (list Period_repr.encoding)) + (req "endorsers_per_block" uint16) + (req "hard_gas_limit_per_operation" z) + (req "hard_gas_limit_per_block" z)) + (merge_objs + (obj8 + (req "proof_of_work_threshold" int64) + (req "tokens_per_roll" Tez_repr.encoding) + (req "michelson_maximum_type_size" uint16) + (req "seed_nonce_revelation_tip" Tez_repr.encoding) + (req "origination_size" int31) + (req "block_security_deposit" Tez_repr.encoding) + (req "endorsement_security_deposit" Tez_repr.encoding) + (req "block_reward" Tez_repr.encoding)) + (obj4 + (req "endorsement_reward" Tez_repr.encoding) + (req "cost_per_byte" Tez_repr.encoding) + (req "hard_storage_limit_per_operation" z) + (req "test_chain_duration" int64)))) + +type t = { + fixed : fixed ; + parametric : parametric ; +} + +let encoding = + let open Data_encoding in + conv + (fun { fixed ; parametric } -> (fixed, parametric)) + (fun (fixed , parametric) -> { fixed ; parametric }) + (merge_objs fixed_encoding parametric_encoding) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml new file mode 100644 index 000000000..8e07c7a87 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml @@ -0,0 +1,65 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +let custom_root = + (RPC_path.(open_root / "context" / "constants") : RPC_context.t RPC_path.context) + +module S = struct + + open Data_encoding + + let errors = + RPC_service.get_service + ~description: "Schema for all the RPC errors from this protocol version" + ~query: RPC_query.empty + ~output: json_schema + RPC_path.(custom_root / "errors") + + let all = + RPC_service.get_service + ~description: "All constants" + ~query: RPC_query.empty + ~output: Alpha_context.Constants.encoding + custom_root + +end + +let register () = + let open Services_registration in + register0_noctxt S.errors begin fun () () -> + return (Data_encoding.Json.(schema error_encoding)) + end ; + register0 S.all begin fun ctxt () () -> + let open Constants in + return { fixed = fixed ; + parametric = parametric ctxt } + end + +let errors ctxt block = + RPC_context.make_call0 S.errors ctxt block () () +let all ctxt block = + RPC_context.make_call0 S.all ctxt block () () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli new file mode 100644 index 000000000..5234cd843 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli @@ -0,0 +1,35 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val errors: + 'a #RPC_context.simple -> 'a -> Data_encoding.json_schema shell_tzresult Lwt.t + +(** Returns all the constants of the protocol *) +val all: + 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t + +val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml new file mode 100644 index 000000000..3ede67cc2 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml @@ -0,0 +1,90 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let preserved_cycles c = + let constants = Raw_context.constants c in + constants.preserved_cycles +let blocks_per_cycle c = + let constants = Raw_context.constants c in + constants.blocks_per_cycle +let blocks_per_commitment c = + let constants = Raw_context.constants c in + constants.blocks_per_commitment +let blocks_per_roll_snapshot c = + let constants = Raw_context.constants c in + constants.blocks_per_roll_snapshot +let blocks_per_voting_period c = + let constants = Raw_context.constants c in + constants.blocks_per_voting_period +let time_between_blocks c = + let constants = Raw_context.constants c in + constants.time_between_blocks +let endorsers_per_block c = + let constants = Raw_context.constants c in + constants.endorsers_per_block +let hard_gas_limit_per_operation c = + let constants = Raw_context.constants c in + constants.hard_gas_limit_per_operation +let hard_gas_limit_per_block c = + let constants = Raw_context.constants c in + constants.hard_gas_limit_per_block +let cost_per_byte c = + let constants = Raw_context.constants c in + constants.cost_per_byte +let hard_storage_limit_per_operation c = + let constants = Raw_context.constants c in + constants.hard_storage_limit_per_operation +let proof_of_work_threshold c = + let constants = Raw_context.constants c in + constants.proof_of_work_threshold +let tokens_per_roll c = + let constants = Raw_context.constants c in + constants.tokens_per_roll +let michelson_maximum_type_size c = + let constants = Raw_context.constants c in + constants.michelson_maximum_type_size +let seed_nonce_revelation_tip c = + let constants = Raw_context.constants c in + constants.seed_nonce_revelation_tip +let origination_size c = + let constants = Raw_context.constants c in + constants.origination_size +let block_security_deposit c = + let constants = Raw_context.constants c in + constants.block_security_deposit +let endorsement_security_deposit c = + let constants = Raw_context.constants c in + constants.endorsement_security_deposit +let block_reward c = + let constants = Raw_context.constants c in + constants.block_reward +let endorsement_reward c = + let constants = Raw_context.constants c in + constants.endorsement_reward +let test_chain_duration c = + let constants = Raw_context.constants c in + constants.test_chain_duration +let parametric c = + Raw_context.constants c diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml new file mode 100644 index 000000000..74b2bbf54 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml @@ -0,0 +1,37 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* 20 *) +let contract_hash = "\002\090\121" (* KT1(36) *) + +include Blake2B.Make(Base58)(struct + let name = "Contract_hash" + let title = "A contract ID" + let b58check_prefix = contract_hash + let size = Some 20 + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "KT1" 36 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml new file mode 100644 index 000000000..95e974ef4 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml @@ -0,0 +1,212 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = + | Implicit of Signature.Public_key_hash.t + | Originated of Contract_hash.t + +include Compare.Make(struct + type nonrec t = t + let compare l1 l2 = + match l1, l2 with + | Implicit pkh1, Implicit pkh2 -> + Signature.Public_key_hash.compare pkh1 pkh2 + | Originated h1, Originated h2 -> + Contract_hash.compare h1 h2 + | Implicit _, Originated _ -> -1 + | Originated _, Implicit _ -> 1 + end) + +type contract = t + +type error += Invalid_contract_notation of string (* `Permanent *) + +let to_b58check = function + | Implicit pbk -> Signature.Public_key_hash.to_b58check pbk + | Originated h -> Contract_hash.to_b58check h + +let of_b58check s = + match Base58.decode s with + | Some (Ed25519.Public_key_hash.Data h) -> ok (Implicit (Signature.Ed25519 h)) + | Some (Secp256k1.Public_key_hash.Data h) -> ok (Implicit (Signature.Secp256k1 h)) + | Some (P256.Public_key_hash.Data h) -> ok (Implicit (Signature.P256 h)) + | Some (Contract_hash.Data h) -> ok (Originated h) + | _ -> error (Invalid_contract_notation s) + +let pp ppf = function + | Implicit pbk -> Signature.Public_key_hash.pp ppf pbk + | Originated h -> Contract_hash.pp ppf h + +let pp_short ppf = function + | Implicit pbk -> Signature.Public_key_hash.pp_short ppf pbk + | Originated h -> Contract_hash.pp_short ppf h + +let encoding = + let open Data_encoding in + def "contract_id" + ~title: + "A contract handle" + ~description: + "A contract notation as given to an RPC or inside scripts. \ + Can be a base58 implicit contract hash \ + or a base58 originated contract hash." @@ + splitted + ~binary: + (union ~tag_size:`Uint8 [ + case (Tag 0) + ~title:"Implicit" + Signature.Public_key_hash.encoding + (function Implicit k -> Some k | _ -> None) + (fun k -> Implicit k) ; + case (Tag 1) (Fixed.add_padding Contract_hash.encoding 1) + ~title:"Originated" + (function Originated k -> Some k | _ -> None) + (fun k -> Originated k) ; + ]) + ~json: + (conv + to_b58check + (fun s -> + match of_b58check s with + | Ok s -> s + | Error _ -> Json.cannot_destruct "Invalid contract notation.") + string) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"contract.invalid_contract_notation" + ~title: "Invalid contract notation" + ~pp: (fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x) + ~description: + "A malformed contract notation was given to an RPC or in a script." + (obj1 (req "notation" string)) + (function Invalid_contract_notation loc -> Some loc | _ -> None) + (fun loc -> Invalid_contract_notation loc) + +let implicit_contract id = Implicit id + +let is_implicit = function + | Implicit m -> Some m + | Originated _ -> None + +let is_originated = function + | Implicit _ -> None + | Originated h -> Some h + +type origination_nonce = + { operation_hash: Operation_hash.t ; + origination_index: int32 } + +let origination_nonce_encoding = + let open Data_encoding in + conv + (fun { operation_hash ; origination_index } -> + (operation_hash, origination_index)) + (fun (operation_hash, origination_index) -> + { operation_hash ; origination_index }) @@ + obj2 + (req "operation" Operation_hash.encoding) + (dft "index" int32 0l) + +let originated_contract nonce = + let data = + Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce in + Originated (Contract_hash.hash_bytes [data]) + +let originated_contracts + ~since: { origination_index = first ; operation_hash = first_hash } + ~until: ({ origination_index = last ; operation_hash = last_hash } as origination_nonce) = + assert (Operation_hash.equal first_hash last_hash) ; + let rec contracts acc origination_index = + if Compare.Int32.(origination_index < first) then + acc + else + let origination_nonce = + { origination_nonce with origination_index } in + let acc = originated_contract origination_nonce :: acc in + contracts acc (Int32.pred origination_index) in + contracts [] (Int32.pred last) + +let initial_origination_nonce operation_hash = + { operation_hash ; origination_index = 0l } + +let incr_origination_nonce nonce = + let origination_index = Int32.succ nonce.origination_index in + { nonce with origination_index } + +let rpc_arg = + let construct = to_b58check in + let destruct hash = + match of_b58check hash with + | Error _ -> Error "Cannot parse contract id" + | Ok contract -> Ok contract in + RPC_arg.make + ~descr: "A contract identifier encoded in b58check." + ~name: "contract_id" + ~construct + ~destruct + () + +module Index = struct + + type t = contract + + let path_length = 7 + + let to_path c l = + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let `Hex key = MBytes.to_hex raw_key in + let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: + String.sub index_key 2 2 :: + String.sub index_key 4 2 :: + String.sub index_key 6 2 :: + String.sub index_key 8 2 :: + String.sub index_key 10 2 :: + key :: + l + + let of_path = function + | [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_] + | _::_::_::_::_::_::_::_::_ -> + None + | [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] -> + let raw_key = MBytes.of_hex (`Hex key) in + let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + assert Compare.String.(String.sub index_key 0 2 = index1) ; + assert Compare.String.(String.sub index_key 2 2 = index2) ; + assert Compare.String.(String.sub index_key 4 2 = index3) ; + assert Compare.String.(String.sub index_key 6 2 = index4) ; + assert Compare.String.(String.sub index_key 8 2 = index5) ; + assert Compare.String.(String.sub index_key 10 2 = index6) ; + Data_encoding.Binary.of_bytes encoding raw_key + + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli new file mode 100644 index 000000000..08ced771a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli @@ -0,0 +1,79 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = private + | Implicit of Signature.Public_key_hash.t + | Originated of Contract_hash.t +type contract = t + +include Compare.S with type t := contract + +(** {2 Implicit contracts} *****************************************************) + +val implicit_contract : Signature.Public_key_hash.t -> contract + +val is_implicit : contract -> Signature.Public_key_hash.t option + +(** {2 Originated contracts} **************************************************) + +(** Originated contracts handles are crafted from the hash of the + operation that triggered their origination (and nothing else). + As a single operation can trigger several originations, the + corresponding handles are forged from a deterministic sequence of + nonces, initialized with the hash of the operation. *) +type origination_nonce + +val originated_contract : origination_nonce -> contract + +val originated_contracts : since: origination_nonce -> until: origination_nonce -> contract list + +val initial_origination_nonce : Operation_hash.t -> origination_nonce + +val incr_origination_nonce : origination_nonce -> origination_nonce + +val is_originated : contract -> Contract_hash.t option + + +(** {2 Human readable notation} ***********************************************) + +type error += Invalid_contract_notation of string (* `Permanent *) + +val to_b58check: contract -> string + +val of_b58check: string -> contract tzresult + +val pp: Format.formatter -> contract -> unit + +val pp_short: Format.formatter -> contract -> unit + +(** {2 Serializers} ***********************************************************) + +val encoding : contract Data_encoding.t + +val origination_nonce_encoding : origination_nonce Data_encoding.t + +val rpc_arg : contract RPC_arg.arg + +module Index : Storage_description.INDEX with type t = t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml new file mode 100644 index 000000000..3951a34ae --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml @@ -0,0 +1,273 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +let custom_root = + (RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context) + +type info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + counter: counter ; + script: Script.t option ; +} + +let info_encoding = + let open Data_encoding in + conv + (fun {manager ; balance ; spendable ; delegate ; + script ; counter } -> + (manager, balance, spendable, delegate, + script, counter)) + (fun (manager, balance, spendable, delegate, + script, counter) -> + {manager ; balance ; spendable ; delegate ; + script ; counter}) @@ + obj6 + (req "manager" Signature.Public_key_hash.encoding) + (req "balance" Tez.encoding) + (req "spendable" bool) + (req "delegate" @@ obj2 + (req "setable" bool) + (opt "value" Signature.Public_key_hash.encoding)) + (opt "script" Script.encoding) + (req "counter" n) + +module S = struct + + open Data_encoding + + let balance = + RPC_service.get_service + ~description: "Access the balance of a contract." + ~query: RPC_query.empty + ~output: Tez.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "balance") + + let manager = + RPC_service.get_service + ~description: "Access the manager of a contract." + ~query: RPC_query.empty + ~output: Signature.Public_key_hash.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "manager") + + let manager_key = + RPC_service.get_service + ~description: "Access the manager of a contract." + ~query: RPC_query.empty + ~output: (obj2 + (req "manager" Signature.Public_key_hash.encoding) + (opt "key" Signature.Public_key.encoding)) + RPC_path.(custom_root /: Contract.rpc_arg / "manager_key") + + let delegate = + RPC_service.get_service + ~description: "Access the delegate of a contract, if any." + ~query: RPC_query.empty + ~output: Signature.Public_key_hash.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "delegate") + + let counter = + RPC_service.get_service + ~description: "Access the counter of a contract, if any." + ~query: RPC_query.empty + ~output: z + RPC_path.(custom_root /: Contract.rpc_arg / "counter") + + let spendable = + RPC_service.get_service + ~description: "Tells if the contract tokens can be spent by the manager." + ~query: RPC_query.empty + ~output: bool + RPC_path.(custom_root /: Contract.rpc_arg / "spendable") + + let delegatable = + RPC_service.get_service + ~description: "Tells if the contract delegate can be changed." + ~query: RPC_query.empty + ~output: bool + RPC_path.(custom_root /: Contract.rpc_arg / "delegatable") + + let script = + RPC_service.get_service + ~description: "Access the code and data of the contract." + ~query: RPC_query.empty + ~output: Script.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "script") + + let storage = + RPC_service.get_service + ~description: "Access the data of the contract." + ~query: RPC_query.empty + ~output: Script.expr_encoding + RPC_path.(custom_root /: Contract.rpc_arg / "storage") + + let big_map_get = + RPC_service.post_service + ~description: "Access the value associated with a key in the big map storage of the contract." + ~query: RPC_query.empty + ~input: (obj2 + (req "key" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output: (option Script.expr_encoding) + RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + + let info = + RPC_service.get_service + ~description: "Access the complete status of a contract." + ~query: RPC_query.empty + ~output: info_encoding + RPC_path.(custom_root /: Contract.rpc_arg) + + let list = + RPC_service.get_service + ~description: + "All existing contracts (including non-empty default contracts)." + ~query: RPC_query.empty + ~output: (list Contract.encoding) + custom_root + +end + +let register () = + let open Services_registration in + register0 S.list begin fun ctxt () () -> + Contract.list ctxt >>= return + end ; + let register_field s f = + register1 s (fun ctxt contract () () -> + Contract.exists ctxt contract >>=? function + | true -> f ctxt contract + | false -> raise Not_found) in + let register_opt_field s f = + register_field s + (fun ctxt a1 -> + f ctxt a1 >>=? function + | None -> raise Not_found + | Some v -> return v) in + register_field S.balance Contract.get_balance ; + register_field S.manager Contract.get_manager ; + register_field S.manager_key + (fun ctxt c -> + Contract.get_manager ctxt c >>=? fun mgr -> + Contract.is_manager_key_revealed ctxt c >>=? fun revealed -> + if revealed then + Contract.get_manager_key ctxt c >>=? fun key -> + return (mgr, Some key) + else return (mgr, None)) ; + register_opt_field S.delegate Delegate.get ; + register_field S.counter Contract.get_counter ; + register_field S.spendable Contract.is_spendable ; + register_field S.delegatable Contract.is_delegatable ; + register_opt_field S.script + (fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ; + register_opt_field S.storage (fun ctxt contract -> + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> + match script with + | None -> return_none + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt Readable script >>=? fun (script, ctxt) -> + Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) -> + return_some storage) ; + register1 S.big_map_get (fun ctxt contract () (key, key_type) -> + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root key_type)) + >>=? fun (Ex_ty key_type, ctxt) -> + parse_data ctxt key_type (Micheline.root key) >>=? fun (key, ctxt) -> + hash_data ctxt key_type key >>=? fun (key_hash, ctxt) -> + Contract.Big_map.get_opt ctxt contract key_hash >>=? fun (_ctxt, value) -> + return value) ; + register_field S.info (fun ctxt contract -> + Contract.get_balance ctxt contract >>=? fun balance -> + Contract.get_manager ctxt contract >>=? fun manager -> + Delegate.get ctxt contract >>=? fun delegate -> + Contract.get_counter ctxt contract >>=? fun counter -> + Contract.is_delegatable ctxt contract >>=? fun delegatable -> + Contract.is_spendable ctxt contract >>=? fun spendable -> + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> + begin match script with + | None -> return (None, ctxt) + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt Readable script >>=? fun (script, ctxt) -> + return (Some script, ctxt) + end >>=? fun (script, _ctxt) -> + return { manager ; balance ; + spendable ; delegate = (delegatable, delegate) ; + script ; counter }) + +let list ctxt block = + RPC_context.make_call0 S.list ctxt block () () + +let info ctxt block contract = + RPC_context.make_call1 S.info ctxt block contract () () + +let balance ctxt block contract = + RPC_context.make_call1 S.balance ctxt block contract () () + +let manager ctxt block contract = + RPC_context.make_call1 S.manager ctxt block contract () () + +let manager_key ctxt block contract = + RPC_context.make_call1 S.manager_key ctxt block contract () () + +let delegate ctxt block contract = + RPC_context.make_call1 S.delegate ctxt block contract () () + +let delegate_opt ctxt block contract = + RPC_context.make_opt_call1 S.delegate ctxt block contract () () + +let counter ctxt block contract = + RPC_context.make_call1 S.counter ctxt block contract () () + +let is_delegatable ctxt block contract = + RPC_context.make_call1 S.delegatable ctxt block contract () () + +let is_spendable ctxt block contract = + RPC_context.make_call1 S.spendable ctxt block contract () () + +let script ctxt block contract = + RPC_context.make_call1 S.script ctxt block contract () () + +let script_opt ctxt block contract = + RPC_context.make_opt_call1 S.script ctxt block contract () () + +let storage ctxt block contract = + RPC_context.make_call1 S.storage ctxt block contract () () + +let storage_opt ctxt block contract = + RPC_context.make_opt_call1 S.storage ctxt block contract () () + +let big_map_get_opt ctxt block contract key = + RPC_context.make_call1 S.big_map_get ctxt block contract () key diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli new file mode 100644 index 000000000..0682c387b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli @@ -0,0 +1,86 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val list: + 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t + +type info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + counter: counter ; + script: Script.t option ; +} + +val info_encoding: info Data_encoding.t + +val info: + 'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t + +val balance: + 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t + +val manager: + 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t + +val manager_key: + 'a #RPC_context.simple -> 'a -> Contract.t -> (public_key_hash * public_key option) shell_tzresult Lwt.t + +val delegate: + 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t + +val delegate_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t + +val is_delegatable: + 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t + +val is_spendable: + 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t + +val counter: + 'a #RPC_context.simple -> 'a -> Contract.t -> counter shell_tzresult Lwt.t + +val script: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t + +val script_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t option shell_tzresult Lwt.t + +val storage: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t + +val storage_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t + +val big_map_get_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> + Script.expr option shell_tzresult Lwt.t + + +val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml new file mode 100644 index 000000000..cc75a1c0d --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml @@ -0,0 +1,526 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *) + | Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *) + | Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *) + | Unspendable_contract of Contract_repr.contract (* `Permanent *) + | Non_existing_contract of Contract_repr.contract (* `Temporary *) + | Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *) + | Empty_transaction of Contract_repr.t (* `Temporary *) + | Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *) + | Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *) + | Failure of string (* `Permanent *) + | Previously_revealed_key of Contract_repr.t (* `Permanent *) + | Unrevealed_manager_key of Contract_repr.t (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"contract.unspendable_contract" + ~title:"Unspendable contract" + ~description:"An operation tried to spend tokens from an unspendable contract" + ~pp:(fun ppf c -> + Format.fprintf ppf "The tokens of contract %a can only be spent by its script" + Contract_repr.pp c) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Unspendable_contract c -> Some c | _ -> None) + (fun c -> Unspendable_contract c) ; + register_error_kind + `Temporary + ~id:"contract.balance_too_low" + ~title:"Balance too low" + ~description:"An operation tried to spend more tokens than the contract has" + ~pp:(fun ppf (c, b, a) -> + Format.fprintf ppf "Balance of contract %a too low (%a) to spend %a" + Contract_repr.pp c Tez_repr.pp b Tez_repr.pp a) + Data_encoding.(obj3 + (req "contract" Contract_repr.encoding) + (req "balance" Tez_repr.encoding) + (req "amount" Tez_repr.encoding)) + (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None) + (fun (c, b, a) -> Balance_too_low (c, b, a)) ; + register_error_kind + `Temporary + ~id:"contract.counter_in_the_future" + ~title:"Invalid counter (not yet reached) in a manager operation" + ~description:"An operation assumed a contract counter in the future" + ~pp:(fun ppf (contract, exp, found) -> + Format.fprintf ppf + "Counter %s not yet reached for contract %a (expected %s)" + (Z.to_string found) + Contract_repr.pp contract + (Z.to_string exp)) + Data_encoding. + (obj3 + (req "contract" Contract_repr.encoding) + (req "expected" z) + (req "found" z)) + (function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None) + (fun (c, x, y) -> Counter_in_the_future (c, x, y)) ; + register_error_kind + `Branch + ~id:"contract.counter_in_the_past" + ~title:"Invalid counter (already used) in a manager operation" + ~description:"An operation assumed a contract counter in the past" + ~pp:(fun ppf (contract, exp, found) -> + Format.fprintf ppf + "Counter %s already used for contract %a (expected %s)" + (Z.to_string found) + Contract_repr.pp contract + (Z.to_string exp)) + Data_encoding. + (obj3 + (req "contract" Contract_repr.encoding) + (req "expected" z) + (req "found" z)) + (function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None) + (fun (c, x, y) -> Counter_in_the_past (c, x, y)) ; + register_error_kind + `Temporary + ~id:"contract.non_existing_contract" + ~title:"Non existing contract" + ~description:"A contract handle is not present in the context \ + (either it never was or it has been destroyed)" + ~pp:(fun ppf contract -> + Format.fprintf ppf "Contract %a does not exist" + Contract_repr.pp contract) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Non_existing_contract c -> Some c | _ -> None) + (fun c -> Non_existing_contract c) ; + register_error_kind + `Permanent + ~id:"contract.manager.inconsistent_hash" + ~title:"Inconsistent public key hash" + ~description:"A revealed manager public key is inconsistent with the announced hash" + ~pp:(fun ppf (k, eh, ph) -> + Format.fprintf ppf "The hash of the manager public key %s is not %a as announced but %a" + (Signature.Public_key.to_b58check k) + Signature.Public_key_hash.pp ph + Signature.Public_key_hash.pp eh) + Data_encoding.(obj3 + (req "public_key" Signature.Public_key.encoding) + (req "expected_hash" Signature.Public_key_hash.encoding) + (req "provided_hash" Signature.Public_key_hash.encoding)) + (function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None) + (fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ; + register_error_kind + `Permanent + ~id:"contract.manager.inconsistent_public_key" + ~title:"Inconsistent public key" + ~description:"A provided manager public key is different with the public key stored in the contract" + ~pp:(fun ppf (eh, ph) -> + Format.fprintf ppf "Expected manager public key %s but %s was provided" + (Signature.Public_key.to_b58check ph) + (Signature.Public_key.to_b58check eh)) + Data_encoding.(obj2 + (req "public_key" Signature.Public_key.encoding) + (req "expected_public_key" Signature.Public_key.encoding)) + (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None) + (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ; + register_error_kind + `Permanent + ~id:"contract.failure" + ~title:"Contract storage failure" + ~description:"Unexpected contract storage error" + ~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s) + Data_encoding.(obj1 (req "message" string)) + (function Failure s -> Some s | _ -> None) + (fun s -> Failure s) ; + register_error_kind + `Branch + ~id:"contract.unrevealed_key" + ~title:"Manager operation precedes key revelation" + ~description: + "One tried to apply a manager operation \ + without revealing the manager public key" + ~pp:(fun ppf s -> + Format.fprintf ppf "Unrevealed manager key for contract %a." + Contract_repr.pp s) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Unrevealed_manager_key s -> Some s | _ -> None) + (fun s -> Unrevealed_manager_key s) ; + register_error_kind + `Branch + ~id:"contract.previously_revealed_key" + ~title:"Manager operation already revealed" + ~description: + "One tried to revealed twice a manager public key" + ~pp:(fun ppf s -> + Format.fprintf ppf "Previously revealed manager key for contract %a." + Contract_repr.pp s) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Previously_revealed_key s -> Some s | _ -> None) + (fun s -> Previously_revealed_key s) ; + register_error_kind + `Branch + ~id:"implicit.empty_implicit_contract" + ~title:"Empty implicit contract" + ~description:"No manager operations are allowed on an empty implicit contract." + ~pp:(fun ppf implicit -> + Format.fprintf ppf + "Empty implicit contract (%a)" + Signature.Public_key_hash.pp implicit) + Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding)) + (function Empty_implicit_contract c -> Some c | _ -> None) + (fun c -> Empty_implicit_contract c) ; + register_error_kind + `Branch + ~id:"contract.empty_transaction" + ~title:"Empty transaction" + ~description:"Forbidden to credit 0ꜩ to a contract without code." + ~pp:(fun ppf contract -> + Format.fprintf ppf + "Transaction of 0ꜩ towards a contract without code are forbidden (%a)." + Contract_repr.pp contract) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Empty_transaction c -> Some c | _ -> None) + (fun c -> Empty_transaction c) + +let failwith msg = fail (Failure msg) + +type big_map_diff_item = { + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; +} +type big_map_diff = big_map_diff_item list + +let big_map_diff_item_encoding = + let open Data_encoding in + conv + (fun { diff_key_hash ; diff_key ; diff_value } -> (diff_key_hash, diff_key, diff_value)) + (fun (diff_key_hash, diff_key, diff_value) -> { diff_key_hash ; diff_key ; diff_value }) + (obj3 + (req "key_hash" Script_expr_hash.encoding) + (req "key" Script_repr.expr_encoding) + (opt "value" Script_repr.expr_encoding)) + +let big_map_diff_encoding = + let open Data_encoding in + def "contract.big_map_diff" @@ + list big_map_diff_item_encoding + +let update_script_big_map c contract = function + | None -> return (c, Z.zero) + | Some diff -> + fold_left_s (fun (c, total) diff_item -> + match diff_item.diff_value with + | None -> + Storage.Contract.Big_map.remove (c, contract) diff_item.diff_key_hash + >>=? fun (c, freed) -> + return (c, Z.sub total (Z.of_int freed)) + | Some v -> + Storage.Contract.Big_map.init_set (c, contract) diff_item.diff_key_hash v + >>=? fun (c, size_diff) -> + return (c, Z.add total (Z.of_int size_diff))) + (c, Z.zero) diff + +let create_base c + ?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *) + contract + ~balance ~manager ~delegate ?script ~spendable ~delegatable = + (match Contract_repr.is_implicit contract with + | None -> return Z.zero + | Some _ -> Storage.Contract.Global_counter.get c) >>=? fun counter -> + Storage.Contract.Balance.init c contract balance >>=? fun c -> + Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) >>=? fun c -> + begin + match delegate with + | None -> return c + | Some delegate -> + Delegate_storage.init c contract delegate + end >>=? fun c -> + Storage.Contract.Spendable.set c contract spendable >>= fun c -> + Storage.Contract.Delegatable.set c contract delegatable >>= fun c -> + Storage.Contract.Counter.init c contract counter >>=? fun c -> + (match script with + | Some ({ Script_repr.code ; storage }, big_map_diff) -> + Storage.Contract.Code.init c contract code >>=? fun (c, code_size) -> + Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) -> + update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size) -> + let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in + assert Compare.Z.(total_size >= Z.zero) ; + let prepaid_bootstrap_storage = + if prepaid_bootstrap_storage then + total_size + else + Z.zero + in + Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c -> + Storage.Contract.Used_storage_space.init c contract total_size + | None -> begin + match Contract_repr.is_implicit contract with + | None -> + Storage.Contract.Paid_storage_space.init c contract Z.zero >>=? fun c -> + Storage.Contract.Used_storage_space.init c contract Z.zero + | Some _ -> + return c + end >>=? fun c -> + return c) >>=? fun c -> + return c + +let originate c ?prepaid_bootstrap_storage contract + ~balance ~manager ?script ~delegate ~spendable ~delegatable = + create_base c ?prepaid_bootstrap_storage contract ~balance ~manager + ~delegate ?script ~spendable ~delegatable + +let create_implicit c manager ~balance = + create_base c (Contract_repr.implicit_contract manager) + ~balance ~manager ?script:None ~delegate:None + ~spendable:true ~delegatable:false + +let delete c contract = + match Contract_repr.is_implicit contract with + | None -> + (* For non implicit contract Big_map should be cleared *) + failwith "Non implicit contracts cannot be removed" + | Some _ -> + Delegate_storage.remove c contract >>=? fun c -> + Storage.Contract.Balance.delete c contract >>=? fun c -> + Storage.Contract.Manager.delete c contract >>=? fun c -> + Storage.Contract.Spendable.del c contract >>= fun c -> + Storage.Contract.Delegatable.del c contract >>= fun c -> + Storage.Contract.Counter.delete c contract >>=? fun c -> + Storage.Contract.Code.remove c contract >>=? fun (c, _) -> + Storage.Contract.Storage.remove c contract >>=? fun (c, _) -> + Storage.Contract.Paid_storage_space.remove c contract >>= fun c -> + Storage.Contract.Used_storage_space.remove c contract >>= fun c -> + return c + +let allocated c contract = + Storage.Contract.Counter.get_option c contract >>=? function + | None -> return_false + | Some _ -> return_true + +let exists c contract = + match Contract_repr.is_implicit contract with + | Some _ -> return_true + | None -> allocated c contract + +let must_exist c contract = + exists c contract >>=? function + | true -> return_unit + | false -> fail (Non_existing_contract contract) + +let must_be_allocated c contract = + allocated c contract >>=? function + | true -> return_unit + | false -> + match Contract_repr.is_implicit contract with + | Some pkh -> fail (Empty_implicit_contract pkh) + | None -> fail (Non_existing_contract contract) + +let list c = Storage.Contract.list c + +let fresh_contract_from_current_nonce c = + Lwt.return (Raw_context.increment_origination_nonce c) >>=? fun (c, nonce) -> + return (c, Contract_repr.originated_contract nonce) + +let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until = + Lwt.return (Raw_context.origination_nonce ctxt_since) >>=? fun since -> + Lwt.return (Raw_context.origination_nonce ctxt_until) >>=? fun until -> + filter_map_s + (fun contract -> exists ctxt_until contract >>=? function + | true -> return_some contract + | false -> return_none) + (Contract_repr.originated_contracts ~since ~until) + +let check_counter_increment c contract counter = + Storage.Contract.Counter.get c contract >>=? fun contract_counter -> + let expected = Z.succ contract_counter in + if Compare.Z.(expected = counter) + then return_unit + else if Compare.Z.(expected > counter) then + fail (Counter_in_the_past (contract, expected, counter)) + else + fail (Counter_in_the_future (contract, expected, counter)) + +let increment_counter c contract = + Storage.Contract.Global_counter.get c >>=? fun global_counter -> + Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c -> + Storage.Contract.Counter.get c contract >>=? fun contract_counter -> + Storage.Contract.Counter.set c contract (Z.succ contract_counter) + +let get_script c contract = + Storage.Contract.Code.get_option c contract >>=? fun (c, code) -> + Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) -> + match code, storage with + | None, None -> return (c, None) + | Some code, Some storage -> return (c, Some { Script_repr.code ; storage }) + | None, Some _ | Some _, None -> failwith "get_script" + +let get_storage ctxt contract = + Storage.Contract.Storage.get_option ctxt contract >>=? function + | (ctxt, None) -> return (ctxt, None) + | (ctxt, Some storage) -> + Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, cost) -> + Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt -> + return (ctxt, Some storage) + +let get_counter c contract = + Storage.Contract.Counter.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_implicit contract with + | Some _ -> Storage.Contract.Global_counter.get c + | None -> failwith "get_counter" + end + | Some v -> return v + +let get_manager c contract = + Storage.Contract.Manager.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_implicit contract with + | Some manager -> return manager + | None -> failwith "get_manager" + end + | Some (Manager_repr.Hash v) -> return v + | Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v) + +let get_manager_key c contract = + Storage.Contract.Manager.get_option c contract >>=? function + | None -> failwith "get_manager_key" + | Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract) + | Some (Manager_repr.Public_key v) -> return v + +let is_manager_key_revealed c contract = + Storage.Contract.Manager.get_option c contract >>=? function + | None -> return_false + | Some (Manager_repr.Hash _) -> return_false + | Some (Manager_repr.Public_key _) -> return_true + +let reveal_manager_key c contract public_key = + Storage.Contract.Manager.get c contract >>=? function + | Public_key _ -> fail (Previously_revealed_key contract) + | Hash v -> + let actual_hash = Signature.Public_key.hash public_key in + if (Signature.Public_key_hash.equal actual_hash v) then + let v = (Manager_repr.Public_key public_key) in + Storage.Contract.Manager.set c contract v >>=? fun c -> + return c + else fail (Inconsistent_hash (public_key,v,actual_hash)) + +let get_balance c contract = + Storage.Contract.Balance.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_implicit contract with + | Some _ -> return Tez_repr.zero + | None -> failwith "get_balance" + end + | Some v -> return v + +let is_delegatable = Delegate_storage.is_delegatable +let is_spendable c contract = + match Contract_repr.is_implicit contract with + | Some _ -> return_true + | None -> + Storage.Contract.Spendable.mem c contract >>= return + +let update_script_storage c contract storage big_map_diff = + let storage = Script_repr.lazy_expr storage in + update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) -> + Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) -> + Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size -> + let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in + Storage.Contract.Used_storage_space.set c contract new_size + +let spend_from_script c contract amount = + Storage.Contract.Balance.get c contract >>=? fun balance -> + match Tez_repr.(balance -? amount) with + | Error _ -> + fail (Balance_too_low (contract, balance, amount)) + | Ok new_balance -> + Storage.Contract.Balance.set c contract new_balance >>=? fun c -> + Roll_storage.Contract.remove_amount c contract amount >>=? fun c -> + if Tez_repr.(new_balance > Tez_repr.zero) then + return c + else match Contract_repr.is_implicit contract with + | None -> return c (* Never delete originated contracts *) + | Some pkh -> + Delegate_storage.get c contract >>=? function + | Some pkh' -> + (* Don't delete "delegate" contract *) + assert (Signature.Public_key_hash.equal pkh pkh') ; + return c + | None -> + (* Delete empty implicit contract *) + delete c contract + +let credit c contract amount = + begin + if Tez_repr.(amount <> Tez_repr.zero) then + return c + else + Storage.Contract.Code.mem c contract >>=? fun (c, target_has_code) -> + fail_unless target_has_code (Empty_transaction contract) >>=? fun () -> + return c + end >>=? fun c -> + Storage.Contract.Balance.get_option c contract >>=? function + | None -> begin + match Contract_repr.is_implicit contract with + | None -> fail (Non_existing_contract contract) + | Some manager -> + create_implicit c manager ~balance:amount + end + | Some balance -> + Lwt.return Tez_repr.(amount +? balance) >>=? fun balance -> + Storage.Contract.Balance.set c contract balance >>=? fun c -> + Roll_storage.Contract.add_amount c contract amount + +let spend c contract amount = + is_spendable c contract >>=? fun spendable -> + if not spendable + then fail (Unspendable_contract contract) + else spend_from_script c contract amount + +let init c = + Storage.Contract.Global_counter.init c Z.zero + +let used_storage_space c contract = + Storage.Contract.Used_storage_space.get_option c contract >>=? function + | None -> return Z.zero + | Some fees -> return fees + +let paid_storage_space c contract = + Storage.Contract.Paid_storage_space.get_option c contract >>=? function + | None -> return Z.zero + | Some paid_space -> return paid_space + +let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space = + Storage.Contract.Paid_storage_space.get c contract >>=? fun already_paid_space -> + if Compare.Z.(already_paid_space >= new_storage_space) then + return (Z.zero, c) + else + let to_pay = Z.sub new_storage_space already_paid_space in + Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c -> + return (to_pay, c) + +module Big_map = struct + let mem ctxt contract key = + Storage.Contract.Big_map.mem (ctxt, contract) key + let get_opt ctxt contract key = + Storage.Contract.Big_map.get_option (ctxt, contract) key +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli new file mode 100644 index 000000000..00ab16462 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli @@ -0,0 +1,140 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *) + | Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *) + | Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *) + | Unspendable_contract of Contract_repr.contract (* `Permanent *) + | Non_existing_contract of Contract_repr.contract (* `Temporary *) + | Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *) + | Empty_transaction of Contract_repr.t (* `Temporary *) + | Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *) + | Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *) + | Failure of string (* `Permanent *) + | Previously_revealed_key of Contract_repr.t (* `Permanent *) + | Unrevealed_manager_key of Contract_repr.t (* `Permanent *) + +val exists: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t +val must_exist: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t + +val allocated: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t +val must_be_allocated: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t + + +val list: Raw_context.t -> Contract_repr.t list Lwt.t + +val check_counter_increment: + Raw_context.t -> Contract_repr.t -> Z.t -> unit tzresult Lwt.t + +val increment_counter: + Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t + +val is_delegatable: + Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + +val is_spendable: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + +val get_manager: + Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t + +val get_manager_key: + Raw_context.t -> Contract_repr.t -> Signature.Public_key.t tzresult Lwt.t +val is_manager_key_revealed: + Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + +val reveal_manager_key: + Raw_context.t -> Contract_repr.t -> Signature.Public_key.t -> + Raw_context.t tzresult Lwt.t + +val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t +val get_counter: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t + +val get_script: + Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t +val get_storage: + Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t + + +type big_map_diff_item = { + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; +} +type big_map_diff = big_map_diff_item list + +val big_map_diff_encoding : big_map_diff Data_encoding.t + +val update_script_storage: + Raw_context.t -> Contract_repr.t -> + Script_repr.expr -> big_map_diff option -> + Raw_context.t tzresult Lwt.t + +val credit: + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +(** checks that the contract is spendable and decrease_balance *) +val spend: + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +(** decrease_balance even if the contract is not spendable *) +val spend_from_script: + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val originate: + Raw_context.t -> + ?prepaid_bootstrap_storage:bool -> + Contract_repr.t -> + balance:Tez_repr.t -> + manager:Signature.Public_key_hash.t -> + ?script:(Script_repr.t * big_map_diff option) -> + delegate:Signature.Public_key_hash.t option -> + spendable:bool -> + delegatable:bool -> + Raw_context.t tzresult Lwt.t + +val fresh_contract_from_current_nonce : + Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult Lwt.t +val originated_from_current_nonce : + since: Raw_context.t -> + until: Raw_context.t -> + Contract_repr.t list tzresult Lwt.t + +val init: + Raw_context.t -> Raw_context.t tzresult Lwt.t + +val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t +val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t +val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t + +module Big_map : sig + val mem : + Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * bool) tzresult Lwt.t + val get_opt : + Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml new file mode 100644 index 000000000..5c24319e8 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml @@ -0,0 +1,85 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = int32 +type cycle = t + +let encoding = Data_encoding.int32 +let rpc_arg = + let construct = Int32.to_string in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse cycle" + | cycle -> Ok cycle in + RPC_arg.make + ~descr:"A cycle integer" + ~name: "block_cycle" + ~construct + ~destruct + () + +let pp ppf cycle = Format.fprintf ppf "%ld" cycle + +include (Compare.Int32 : Compare.S with type t := t) + +module Map = Map.Make(Compare.Int32) + +let root = 0l +let succ = Int32.succ +let pred = function + | 0l -> None + | i -> Some (Int32.pred i) + +let add c i = + assert Compare.Int.(i > 0) ; + Int32.add c (Int32.of_int i) + +let sub c i = + assert Compare.Int.(i > 0) ; + let r = Int32.sub c (Int32.of_int i) in + if Compare.Int32.(r < 0l) then None else Some r + +let to_int32 i = i + +let of_int32_exn l = + if Compare.Int32.(l >= 0l) + then l + else invalid_arg "Level_repr.Cycle.of_int32" + +module Index = struct + type t = cycle + let path_length = 1 + let to_path c l = + Int32.to_string (to_int32 c) :: l + let of_path = function + | [s] -> begin + try Some (Int32.of_string s) + with _ -> None + end + | _ -> None + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli new file mode 100644 index 000000000..c3502f665 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t +type cycle = t +include Compare.S with type t := t +val encoding: cycle Data_encoding.t +val rpc_arg: cycle RPC_arg.arg +val pp: Format.formatter -> cycle -> unit + +val root: cycle +val pred: cycle -> cycle option +val add: cycle -> int -> cycle +val sub: cycle -> int -> cycle option +val succ: cycle -> cycle + +val to_int32: cycle -> int32 +val of_int32_exn: int32 -> cycle + +module Map : S.MAP with type key = cycle + +module Index : Storage_description.INDEX with type t = cycle diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml new file mode 100644 index 000000000..1f01c3cef --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml @@ -0,0 +1,553 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type info = { + balance: Tez.t ; + frozen_balance: Tez.t ; + frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; + staking_balance: Tez.t ; + delegated_contracts: Contract_hash.t list ; + delegated_balance: Tez.t ; + deactivated: bool ; + grace_period: Cycle.t ; +} + +let info_encoding = + let open Data_encoding in + conv + (fun { balance ; frozen_balance ; frozen_balance_by_cycle ; + staking_balance ; delegated_contracts ; delegated_balance ; + deactivated ; grace_period } -> + (balance, frozen_balance, frozen_balance_by_cycle, + staking_balance, delegated_contracts, delegated_balance, + deactivated, grace_period)) + (fun (balance, frozen_balance, frozen_balance_by_cycle, + staking_balance, delegated_contracts, delegated_balance, + deactivated, grace_period) -> + { balance ; frozen_balance ; frozen_balance_by_cycle ; + staking_balance ; delegated_contracts ; delegated_balance ; + deactivated ; grace_period }) + (obj8 + (req "balance" Tez.encoding) + (req "frozen_balance" Tez.encoding) + (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding) + (req "staking_balance" Tez.encoding) + (req "delegated_contracts" (list Contract_hash.encoding)) + (req "delegated_balance" Tez.encoding) + (req "deactivated" bool) + (req "grace_period" Cycle.encoding)) + +module S = struct + + let path = RPC_path.(open_root / "context" / "delegates") + + open Data_encoding + + type list_query = { + active: bool ; + inactive: bool ; + } + let list_query :list_query RPC_query.t = + let open RPC_query in + query (fun active inactive -> { active ; inactive }) + |+ flag "active" (fun t -> t.active) + |+ flag "inactive" (fun t -> t.inactive) + |> seal + + let list_delegate = + RPC_service.get_service + ~description: + "Lists all registered delegates." + ~query: list_query + ~output: (list Signature.Public_key_hash.encoding) + path + + let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg) + + let info = + RPC_service.get_service + ~description: + "Everything about a delegate." + ~query: RPC_query.empty + ~output: info_encoding + path + + let balance = + RPC_service.get_service + ~description: + "Returns the full balance of a given delegate, \ + including the frozen balances." + ~query: RPC_query.empty + ~output: Tez.encoding + RPC_path.(path / "balance") + + let frozen_balance = + RPC_service.get_service + ~description: + "Returns the total frozen balances of a given delegate, \ + this includes the frozen deposits, rewards and fees." + ~query: RPC_query.empty + ~output: Tez.encoding + RPC_path.(path / "frozen_balance") + + let frozen_balance_by_cycle = + RPC_service.get_service + ~description: + "Returns the frozen balances of a given delegate, \ + indexed by the cycle by which it will be unfrozen" + ~query: RPC_query.empty + ~output: Delegate.frozen_balance_by_cycle_encoding + RPC_path.(path / "frozen_balance_by_cycle") + + let staking_balance = + RPC_service.get_service + ~description: + "Returns the total amount of tokens delegated to a given delegate. \ + This includes the balances of all the contracts that delegate \ + to it, but also the balance of the delegate itself and its frozen \ + fees and deposits. The rewards do not count in the delegated balance \ + until they are unfrozen." + ~query: RPC_query.empty + ~output: Tez.encoding + RPC_path.(path / "staking_balance") + + let delegated_contracts = + RPC_service.get_service + ~description: + "Returns the list of contracts that delegate to a given delegate." + ~query: RPC_query.empty + ~output: (list Contract_hash.encoding) + RPC_path.(path / "delegated_contracts") + + let delegated_balance = + RPC_service.get_service + ~description: + "Returns the balances of all the contracts that delegate to a \ + given delegate. This excludes the delegate's own balance and \ + its frozen balances." + ~query: RPC_query.empty + ~output: Tez.encoding + RPC_path.(path / "delegated_balance") + + let deactivated = + RPC_service.get_service + ~description: + "Tells whether the delegate is currently tagged as deactivated or not." + ~query: RPC_query.empty + ~output: bool + RPC_path.(path / "deactivated") + + let grace_period = + RPC_service.get_service + ~description: + "Returns the cycle by the end of which the delegate might be \ + deactivated if she fails to execute any delegate action. \ + A deactivated delegate might be reactivated \ + (without loosing any rolls) by simply re-registering as a delegate. \ + For deactivated delegates, this value contains the cycle by which \ + they were deactivated." + ~query: RPC_query.empty + ~output: Cycle.encoding + RPC_path.(path / "grace_period") + +end + +let register () = + let open Services_registration in + register0 S.list_delegate begin fun ctxt q () -> + Delegate.list ctxt >>= fun delegates -> + if q.active && q.inactive then + return delegates + else if q.active then + filter_map_s + (fun pkh -> + Delegate.deactivated ctxt pkh >>=? function + | true -> return_none + | false -> return_some pkh) + delegates + else if q.inactive then + filter_map_s + (fun pkh -> + Delegate.deactivated ctxt pkh >>=? function + | false -> return_none + | true -> return_some pkh) + delegates + else + return_nil + end ; + register1 S.info begin fun ctxt pkh () () -> + Delegate.full_balance ctxt pkh >>=? fun balance -> + Delegate.frozen_balance ctxt pkh >>=? fun frozen_balance -> + Delegate.frozen_balance_by_cycle ctxt pkh >>= fun frozen_balance_by_cycle -> + Delegate.staking_balance ctxt pkh >>=? fun staking_balance -> + Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts -> + Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance -> + Delegate.deactivated ctxt pkh >>=? fun deactivated -> + Delegate.grace_period ctxt pkh >>=? fun grace_period -> + return { + balance ; frozen_balance ; frozen_balance_by_cycle ; + staking_balance ; delegated_contracts ; delegated_balance ; + deactivated ; grace_period + } + end ; + register1 S.balance begin fun ctxt pkh () () -> + Delegate.full_balance ctxt pkh + end ; + register1 S.frozen_balance begin fun ctxt pkh () () -> + Delegate.frozen_balance ctxt pkh + end ; + register1 S.frozen_balance_by_cycle begin fun ctxt pkh () () -> + Delegate.frozen_balance_by_cycle ctxt pkh >>= return + end ; + register1 S.staking_balance begin fun ctxt pkh () () -> + Delegate.staking_balance ctxt pkh + end ; + register1 S.delegated_contracts begin fun ctxt pkh () () -> + Delegate.delegated_contracts ctxt pkh >>= return + end ; + register1 S.delegated_balance begin fun ctxt pkh () () -> + Delegate.delegated_balance ctxt pkh + end ; + register1 S.deactivated begin fun ctxt pkh () () -> + Delegate.deactivated ctxt pkh + end ; + register1 S.grace_period begin fun ctxt pkh () () -> + Delegate.grace_period ctxt pkh + end + +let list ctxt block ?(active = true) ?(inactive = false) () = + RPC_context.make_call0 S.list_delegate ctxt block { active ; inactive } () + +let info ctxt block pkh = + RPC_context.make_call1 S.info ctxt block pkh () () + +let balance ctxt block pkh = + RPC_context.make_call1 S.balance ctxt block pkh () () + +let frozen_balance ctxt block pkh = + RPC_context.make_call1 S.frozen_balance ctxt block pkh () () + +let frozen_balance_by_cycle ctxt block pkh = + RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () () + +let staking_balance ctxt block pkh = + RPC_context.make_call1 S.staking_balance ctxt block pkh () () + +let delegated_contracts ctxt block pkh = + RPC_context.make_call1 S.delegated_contracts ctxt block pkh () () + +let delegated_balance ctxt block pkh = + RPC_context.make_call1 S.delegated_balance ctxt block pkh () () + +let deactivated ctxt block pkh = + RPC_context.make_call1 S.deactivated ctxt block pkh () () + +let grace_period ctxt block pkh = + RPC_context.make_call1 S.grace_period ctxt block pkh () () + +let requested_levels ~default ctxt cycles levels = + match levels, cycles with + | [], [] -> + return [default] + | levels, cycles -> + (* explicitly fail when requested levels or cycle are in the past... + or too far in the future... *) + let levels = + List.sort_uniq + Level.compare + (List.concat (List.map (Level.from_raw ctxt) levels :: + List.map (Level.levels_in_cycle ctxt) cycles)) in + map_p + (fun level -> + let current_level = Level.current ctxt in + if Level.(level <= current_level) then + return (level, None) + else + Baking.earlier_predecessor_timestamp + ctxt level >>=? fun timestamp -> + return (level, Some timestamp)) + levels + +module Baking_rights = struct + + type t = { + level: Raw_level.t ; + delegate: Signature.Public_key_hash.t ; + priority: int ; + timestamp: Timestamp.t option ; + } + + let encoding = + let open Data_encoding in + conv + (fun { level ; delegate ; priority ; timestamp } -> + (level, delegate, priority, timestamp)) + (fun (level, delegate, priority, timestamp) -> + { level ; delegate ; priority ; timestamp }) + (obj4 + (req "level" Raw_level.encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "priority" uint16) + (opt "estimated_time" Timestamp.encoding)) + + module S = struct + + open Data_encoding + + let custom_root = + RPC_path.(open_root / "helpers" / "baking_rights") + + type baking_rights_query = { + levels: Raw_level.t list ; + cycles: Cycle.t list ; + delegates: Signature.Public_key_hash.t list ; + max_priority: int option ; + all: bool ; + } + + let baking_rights_query = + let open RPC_query in + query (fun levels cycles delegates max_priority all -> + { levels ; cycles ; delegates ; max_priority ; all }) + |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels) + |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles) + |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates) + |+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority) + |+ flag "all" (fun t -> t.all) + |> seal + + let baking_rights = + RPC_service.get_service + ~description: + "Retrieves the list of delegates allowed to bake a block.\n\ + By default, it gives the best baking priorities for bakers \ + that have at least one opportunity below the 64th priority \ + for the next block.\n\ + Parameters `level` and `cycle` can be used to specify the \ + (valid) level(s) in the past or future at which the baking \ + rights have to be returned. Parameter `delegate` can be \ + used to restrict the results to the given delegates. If \ + parameter `all` is set, all the baking opportunities for \ + each baker at each level are returned, instead of just the \ + first one.\n\ + Returns the list of baking slots. Also returns the minimal \ + timestamps that correspond to these slots. The timestamps \ + are omitted for levels in the past, and are only estimates \ + for levels later that the next block, based on the \ + hypothesis that all predecessor blocks were baked at the \ + first priority." + ~query: baking_rights_query + ~output: (list encoding) + custom_root + + end + + let baking_priorities ctxt max_prio (level, pred_timestamp) = + Baking.baking_priorities ctxt level >>=? fun contract_list -> + let rec loop l acc priority = + if Compare.Int.(priority >= max_prio) then + return (List.rev acc) + else + let Misc.LCons (pk, next) = l in + let delegate = Signature.Public_key.hash pk in + begin + match pred_timestamp with + | None -> return_none + | Some pred_timestamp -> + Baking.minimal_time ctxt priority pred_timestamp >>=? fun t -> + return_some t + end>>=? fun timestamp -> + let acc = + { level = level.level ; delegate ; priority ; timestamp } :: acc in + next () >>=? fun l -> + loop l acc (priority+1) in + loop contract_list [] 0 + + let remove_duplicated_delegates rights = + List.rev @@ fst @@ + List.fold_left + (fun (acc, previous) r -> + if Signature.Public_key_hash.Set.mem r.delegate previous then + (acc, previous) + else + (r :: acc, + Signature.Public_key_hash.Set.add r.delegate previous)) + ([], Signature.Public_key_hash.Set.empty) + rights + + let register () = + let open Services_registration in + register0 S.baking_rights begin fun ctxt q () -> + requested_levels + ~default: + (Level.succ ctxt (Level.current ctxt), Some (Timestamp.current ctxt)) + ctxt q.cycles q.levels >>=? fun levels -> + let max_priority = + match q.max_priority with + | None -> 64 + | Some max -> max in + map_p (baking_priorities ctxt max_priority) levels >>=? fun rights -> + let rights = + if q.all then + rights + else + List.map remove_duplicated_delegates rights in + let rights = List.concat rights in + match q.delegates with + | [] -> return rights + | _ :: _ as delegates -> + let is_requested p = + List.exists (Signature.Public_key_hash.equal p.delegate) delegates in + return (List.filter is_requested rights) + end + + let get ctxt + ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false) + ?max_priority block = + RPC_context.make_call0 S.baking_rights ctxt block + { levels ; cycles ; delegates ; max_priority ; all } + () + +end + +module Endorsing_rights = struct + + type t = { + level: Raw_level.t ; + delegate: Signature.Public_key_hash.t ; + slots: int list ; + estimated_time: Time.t option ; + } + + let encoding = + let open Data_encoding in + conv + (fun { level ; delegate ; slots ; estimated_time } -> + (level, delegate, slots, estimated_time)) + (fun (level, delegate, slots, estimated_time) -> + { level ; delegate ; slots ; estimated_time }) + (obj4 + (req "level" Raw_level.encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "slots" (list uint16)) + (opt "estimated_time" Timestamp.encoding)) + + module S = struct + + open Data_encoding + + let custom_root = + RPC_path.(open_root / "helpers" / "endorsing_rights") + + type endorsing_rights_query = { + levels: Raw_level.t list ; + cycles: Cycle.t list ; + delegates: Signature.Public_key_hash.t list ; + } + + let endorsing_rights_query = + let open RPC_query in + query (fun levels cycles delegates -> + { levels ; cycles ; delegates }) + |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels) + |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles) + |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates) + |> seal + + let endorsing_rights = + RPC_service.get_service + ~description: + "Retrieves the delegates allowed to endorse a block.\n\ + By default, it gives the endorsement slots for delegates that \ + have at least one in the next block.\n\ + Parameters `level` and `cycle` can be used to specify the \ + (valid) level(s) in the past or future at which the \ + endorsement rights have to be returned. Parameter \ + `delegate` can be used to restrict the results to the given \ + delegates.\n\ + Returns the list of endorsement slots. Also returns the \ + minimal timestamps that correspond to these slots. The \ + timestamps are omitted for levels in the past, and are only \ + estimates for levels later that the next block, based on \ + the hypothesis that all predecessor blocks were baked at \ + the first priority." + ~query: endorsing_rights_query + ~output: (list encoding) + custom_root + + end + + let endorsement_slots ctxt (level, estimated_time) = + Baking.endorsement_rights ctxt level >>=? fun rights -> + return + (Signature.Public_key_hash.Map.fold + (fun delegate (_, slots, _) acc -> { + level = level.level ; delegate ; slots ; estimated_time + } :: acc) + rights []) + + let register () = + let open Services_registration in + register0 S.endorsing_rights begin fun ctxt q () -> + requested_levels + ~default: (Level.current ctxt, Some (Timestamp.current ctxt)) + ctxt q.cycles q.levels >>=? fun levels -> + map_p (endorsement_slots ctxt) levels >>=? fun rights -> + let rights = List.concat rights in + match q.delegates with + | [] -> return rights + | _ :: _ as delegates -> + let is_requested p = + List.exists (Signature.Public_key_hash.equal p.delegate) delegates in + return (List.filter is_requested rights) + end + + let get ctxt + ?(levels = []) ?(cycles = []) ?(delegates = []) block = + RPC_context.make_call0 S.endorsing_rights ctxt block + { levels ; cycles ; delegates } + () + +end + +let register () = + register () ; + Baking_rights.register () ; + Endorsing_rights.register () + +let endorsement_rights ctxt level = + Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l -> + return (List.map (fun { Endorsing_rights.delegate ; _ } -> delegate) l) + +let baking_rights ctxt max_priority = + let max = match max_priority with None -> 64 | Some m -> m in + let level = Level.current ctxt in + Baking_rights.baking_priorities ctxt max (level, None) >>=? fun l -> + return (level.level, + List.map + (fun { Baking_rights.delegate ; timestamp ; _ } -> + (delegate, timestamp)) l) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli new file mode 100644 index 000000000..4061a665c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli @@ -0,0 +1,176 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val list: + 'a #RPC_context.simple -> 'a -> + ?active:bool -> + ?inactive:bool -> + unit -> Signature.Public_key_hash.t list shell_tzresult Lwt.t + +type info = { + balance: Tez.t ; + frozen_balance: Tez.t ; + frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; + staking_balance: Tez.t ; + delegated_contracts: Contract_hash.t list ; + delegated_balance: Tez.t ; + deactivated: bool ; + grace_period: Cycle.t ; +} + +val info_encoding: info Data_encoding.t + +val info: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + info shell_tzresult Lwt.t + +val balance: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val frozen_balance: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val frozen_balance_by_cycle: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t + +val staking_balance: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val delegated_contracts: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Contract_hash.t list shell_tzresult Lwt.t + +val delegated_balance: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val deactivated: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + bool shell_tzresult Lwt.t + +val grace_period: + 'a #RPC_context.simple -> 'a -> + Signature.Public_key_hash.t -> + Cycle.t shell_tzresult Lwt.t + + +module Baking_rights : sig + + type t = { + level: Raw_level.t ; + delegate: Signature.Public_key_hash.t ; + priority: int ; + timestamp: Timestamp.t option ; + } + + (** Retrieves the list of delegates allowed to bake a block. + + By default, it gives the best baking priorities for bakers + that have at least one opportunity below the 64th priority for + the next block. + + Parameters [levels] and [cycles] can be used to specify the + (valid) level(s) in the past or future at which the baking rights + have to be returned. Parameter [delegates] can be used to + restrict the results to the given delegates. If parameter [all] + is [true], all the baking opportunities for each baker at each level + are returned, instead of just the first one. + + Returns the list of baking slots. Also returns the minimal + timestamps that correspond to these slots. The timestamps are + omitted for levels in the past, and are only estimates for levels + later that the next block, based on the hypothesis that all + predecessor blocks were baked at the first priority. *) + val get: + 'a #RPC_context.simple -> + ?levels: Raw_level.t list -> + ?cycles: Cycle.t list -> + ?delegates: Signature.public_key_hash list -> + ?all: bool -> + ?max_priority: int -> + 'a -> t list shell_tzresult Lwt.t + +end + +module Endorsing_rights : sig + + type t = { + level: Raw_level.t ; + delegate: Signature.Public_key_hash.t ; + slots: int list ; + estimated_time: Timestamp.t option ; + } + + (** Retrieves the delegates allowed to endorse a block. + + By default, it gives the endorsement slots for bakers that have + at least one in the next block. + + Parameters [levels] and [cycles] can be used to specify the + (valid) level(s) in the past or future at which the endorsement + rights have to be returned. Parameter [delegates] can be used to + restrict the results to the given delegates. Returns the list of + endorsement slots. Also returns the minimal timestamps that + correspond to these slots. + + Timestamps are omitted for levels in the past, and are only + estimates for levels later that the next block, based on the + hypothesis that all predecessor blocks were baked at the first + priority. *) + val get: + 'a #RPC_context.simple -> + ?levels: Raw_level.t list -> + ?cycles: Cycle.t list -> + ?delegates: Signature.public_key_hash list -> + 'a -> t list shell_tzresult Lwt.t + +end + +(* temporary export for deprecated unit test *) +val endorsement_rights: + Alpha_context.t -> + Level.t -> + public_key_hash list tzresult Lwt.t + +val baking_rights: + Alpha_context.t -> + int option -> + (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t + +val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml new file mode 100644 index 000000000..da097d9d6 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml @@ -0,0 +1,626 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type balance = + | Contract of Contract_repr.t + | Rewards of Signature.Public_key_hash.t * Cycle_repr.t + | Fees of Signature.Public_key_hash.t * Cycle_repr.t + | Deposits of Signature.Public_key_hash.t * Cycle_repr.t + +let balance_encoding = + let open Data_encoding in + def "operation_metadata.alpha.balance" @@ + union + [ case (Tag 0) + ~title:"Contract" + (obj2 + (req "kind" (constant "contract")) + (req "contract" Contract_repr.encoding)) + (function Contract c -> Some ((), c) | _ -> None ) + (fun ((), c) -> (Contract c)) ; + case (Tag 1) + ~title:"Rewards" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "rewards")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Rewards (d, l)) ; + case (Tag 2) + ~title:"Fees" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "fees")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Fees (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Fees (d, l)) ; + case (Tag 3) + ~title:"Deposits" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "deposits")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Deposits (d, l)) ] + +type balance_update = + | Debited of Tez_repr.t + | Credited of Tez_repr.t + +let balance_update_encoding = + let open Data_encoding in + def "operation_metadata.alpha.balance_update" @@ + obj1 + (req "change" + (conv + (function + | Credited v -> Tez_repr.to_mutez v + | Debited v -> Int64.neg (Tez_repr.to_mutez v)) + (Json.wrap_error @@ + fun v -> + if Compare.Int64.(v < 0L) then + match Tez_repr.of_mutez (Int64.neg v) with + | Some v -> Debited v + | None -> failwith "Qty.of_mutez" + else + match Tez_repr.of_mutez v with + | Some v -> Credited v + | None -> failwith "Qty.of_mutez") + int64)) + +type balance_updates = (balance * balance_update) list + +let balance_updates_encoding = + let open Data_encoding in + def "operation_metadata.alpha.balance_updates" @@ + list (merge_objs balance_encoding balance_update_encoding) + +let cleanup_balance_updates balance_updates = + List.filter + (fun (_, (Credited update | Debited update)) -> + not (Tez_repr.equal update Tez_repr.zero)) + balance_updates + +type frozen_balance = { + deposit : Tez_repr.t ; + fees : Tez_repr.t ; + rewards : Tez_repr.t ; +} + +let frozen_balance_encoding = + let open Data_encoding in + conv + (fun { deposit ; fees ; rewards } -> (deposit, fees, rewards)) + (fun (deposit, fees, rewards) -> { deposit ; fees ; rewards }) + (obj3 + (req "deposit" Tez_repr.encoding) + (req "fees" Tez_repr.encoding) + (req "rewards" Tez_repr.encoding)) + +type error += + | Non_delegatable_contract of Contract_repr.contract (* `Permanent *) + | No_deletion of Signature.Public_key_hash.t (* `Permanent *) + | Active_delegate (* `Temporary *) + | Current_delegate (* `Temporary *) + | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *) + | Balance_too_low_for_deposit of + { delegate : Signature.Public_key_hash.t ; + deposit : Tez_repr.t ; + balance : Tez_repr.t } (* `Temporary *) + +let () = + register_error_kind + `Permanent + ~id:"contract.undelegatable_contract" + ~title:"Non delegatable contract" + ~description:"Tried to delegate an implicit contract \ + or a non delegatable originated contract" + ~pp:(fun ppf contract -> + Format.fprintf ppf "Contract %a is not delegatable" + Contract_repr.pp contract) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Non_delegatable_contract c -> Some c | _ -> None) + (fun c -> Non_delegatable_contract c) ; + register_error_kind + `Permanent + ~id:"delegate.no_deletion" + ~title:"Forbidden delegate deletion" + ~description:"Tried to unregister a delegate" + ~pp:(fun ppf delegate -> + Format.fprintf ppf "Delegate deletion is forbidden (%a)" + Signature.Public_key_hash.pp delegate) + Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) + (function No_deletion c -> Some c | _ -> None) + (fun c -> No_deletion c) ; + register_error_kind + `Temporary + ~id:"delegate.already_active" + ~title:"Delegate already active" + ~description:"Useless delegate reactivation" + ~pp:(fun ppf () -> + Format.fprintf ppf + "The delegate is still active, no need to refresh it") + Data_encoding.empty + (function Active_delegate -> Some () | _ -> None) + (fun () -> Active_delegate) ; + register_error_kind + `Temporary + ~id:"delegate.unchanged" + ~title:"Unchanged delegated" + ~description:"Contract already delegated to the given delegate" + ~pp:(fun ppf () -> + Format.fprintf ppf + "The contract is already delegated to the same delegate") + Data_encoding.empty + (function Current_delegate -> Some () | _ -> None) + (fun () -> Current_delegate) ; + register_error_kind + `Permanent + ~id:"delegate.empty_delegate_account" + ~title:"Empty delegate account" + ~description:"Cannot register a delegate when its implicit account is empty" + ~pp:(fun ppf delegate -> + Format.fprintf ppf + "Delegate registration is forbidden when the delegate + implicit account is empty (%a)" + Signature.Public_key_hash.pp delegate) + Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) + (function Empty_delegate_account c -> Some c | _ -> None) + (fun c -> Empty_delegate_account c) ; + register_error_kind + `Temporary + ~id:"delegate.balance_too_low_for_deposit" + ~title:"Balance too low for deposit" + ~description:"Cannot freeze deposit when the balance is too low" + ~pp:(fun ppf (delegate, balance, deposit) -> + Format.fprintf ppf + "Delegate %a has a too low balance (%a) to deposit %a" + Signature.Public_key_hash.pp delegate + Tez_repr.pp balance + Tez_repr.pp deposit) + Data_encoding. + (obj3 + (req "delegate" Signature.Public_key_hash.encoding) + (req "balance" Tez_repr.encoding) + (req "deposit" Tez_repr.encoding)) + (function Balance_too_low_for_deposit { delegate ; balance ; deposit } -> + Some (delegate, balance, deposit) | _ -> None) + (fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } ) + +let is_delegatable c contract = + match Contract_repr.is_implicit contract with + | Some _ -> + return_false + | None -> + Storage.Contract.Delegatable.mem c contract >>= return + +let link c contract delegate balance = + Roll_storage.Delegate.add_amount c delegate balance >>=? fun c -> + match Contract_repr.is_originated contract with + | None -> return c + | Some h -> + Storage.Contract.Delegated.add + (c, Contract_repr.implicit_contract delegate) h >>= fun c -> + return c + +let unlink c contract balance = + Storage.Contract.Delegate.get_option c contract >>=? function + | None -> return c + | Some delegate -> + Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c -> + match Contract_repr.is_originated contract with + | None -> return c + | Some h -> + Storage.Contract.Delegated.del + (c, Contract_repr.implicit_contract delegate) h >>= fun c -> + return c + +let known c delegate = + Storage.Contract.Manager.get_option + c (Contract_repr.implicit_contract delegate) >>=? function + | None | Some (Manager_repr.Hash _) -> return_false + | Some (Manager_repr.Public_key _) -> return_true + +(* A delegate is registered if its "implicit account" + delegates to itself. *) +let registered c delegate = + Storage.Contract.Delegate.mem + c (Contract_repr.implicit_contract delegate) + +let init ctxt contract delegate = + known ctxt delegate >>=? fun known_delegate -> + fail_unless + known_delegate + (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> + registered ctxt delegate >>= fun is_registered -> + fail_unless + is_registered + (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> + Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt -> + Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + link ctxt contract delegate balance + +let get = Roll_storage.get_contract_delegate + +let set_base c is_delegatable contract delegate = + match delegate with + | None -> begin + match Contract_repr.is_implicit contract with + | Some pkh -> + fail (No_deletion pkh) + | None -> + is_delegatable c contract >>=? fun delegatable -> + if delegatable then + Storage.Contract.Balance.get c contract >>=? fun balance -> + unlink c contract balance >>=? fun c -> + Storage.Contract.Delegate.remove c contract >>= fun c -> + return c + else + fail (Non_delegatable_contract contract) + end + | Some delegate -> + known c delegate >>=? fun known_delegate -> + registered c delegate >>= fun registered_delegate -> + is_delegatable c contract >>=? fun delegatable -> + let self_delegation = + match Contract_repr.is_implicit contract with + | Some pkh -> Signature.Public_key_hash.equal pkh delegate + | None -> false in + if not known_delegate || not (registered_delegate || self_delegation) then + fail (Roll_storage.Unregistered_delegate delegate) + else if not (delegatable || self_delegation) then + fail (Non_delegatable_contract contract) + else + begin + Storage.Contract.Delegate.get_option c contract >>=? function + | Some current_delegate + when Signature.Public_key_hash.equal delegate current_delegate -> + if self_delegation then + Roll_storage.Delegate.is_inactive c delegate >>=? function + | true -> return_unit + | false -> fail Active_delegate + else + fail Current_delegate + | None | Some _ -> return_unit + end >>=? fun () -> + Storage.Contract.Balance.mem c contract >>= fun exists -> + fail_when + (self_delegation && not exists) + (Empty_delegate_account delegate) >>=? fun () -> + Storage.Contract.Balance.get c contract >>=? fun balance -> + unlink c contract balance >>=? fun c -> + Storage.Contract.Delegate.init_set c contract delegate >>= fun c -> + link c contract delegate balance >>=? fun c -> + begin + if self_delegation then + Storage.Delegates.add c delegate >>= fun c -> + Roll_storage.Delegate.set_active c delegate >>=? fun c -> + return c + else + return c + end >>=? fun c -> + return c + +let set c contract delegate = + set_base c is_delegatable contract delegate + +let set_from_script c contract delegate = + set_base c (fun _ _ -> return_true) contract delegate + +let remove ctxt contract = + Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + unlink ctxt contract balance + +let delegated_contracts ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Delegated.elements (ctxt, contract) + +let get_frozen_deposit ctxt contract cycle = + Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle >>=? function + | None -> return Tez_repr.zero + | Some frozen -> return frozen + +let credit_frozen_deposit ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle >>=? fun old_amount -> + Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount -> + Storage.Contract.Frozen_deposits.init_set + (ctxt, contract) cycle new_amount >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt -> + return ctxt + +let freeze_deposit ctxt delegate amount = + let { Level_repr.cycle ; _ } = Level_storage.current ctxt in + Roll_storage.Delegate.set_active ctxt delegate >>=? fun ctxt -> + let contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + Lwt.return + (record_trace (Balance_too_low_for_deposit { delegate; deposit = amount; balance }) + Tez_repr.(balance -? amount)) >>=? fun new_balance -> + Storage.Contract.Balance.set ctxt contract new_balance >>=? fun ctxt -> + credit_frozen_deposit ctxt delegate cycle amount + +let get_frozen_fees ctxt contract cycle = + Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle >>=? function + | None -> return Tez_repr.zero + | Some frozen -> return frozen + +let credit_frozen_fees ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_fees ctxt contract cycle >>=? fun old_amount -> + Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount -> + Storage.Contract.Frozen_fees.init_set + (ctxt, contract) cycle new_amount >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt -> + return ctxt + +let freeze_fees ctxt delegate amount = + let { Level_repr.cycle ; _ } = Level_storage.current ctxt in + Roll_storage.Delegate.add_amount ctxt delegate amount >>=? fun ctxt -> + credit_frozen_fees ctxt delegate cycle amount + +let burn_fees ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_fees ctxt contract cycle >>=? fun old_amount -> + begin + match Tez_repr.(old_amount -? amount) with + | Ok new_amount -> + Roll_storage.Delegate.remove_amount + ctxt delegate amount >>=? fun ctxt -> + return (new_amount, ctxt) + | Error _ -> + Roll_storage.Delegate.remove_amount + ctxt delegate old_amount >>=? fun ctxt -> + return (Tez_repr.zero, ctxt) + end >>=? fun (new_amount, ctxt) -> + Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount >>= fun ctxt -> + return ctxt + + +let get_frozen_rewards ctxt contract cycle = + Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle >>=? function + | None -> return Tez_repr.zero + | Some frozen -> return frozen + +let credit_frozen_rewards ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_rewards ctxt contract cycle >>=? fun old_amount -> + Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount -> + Storage.Contract.Frozen_rewards.init_set + (ctxt, contract) cycle new_amount >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt -> + return ctxt + +let freeze_rewards ctxt delegate amount = + let { Level_repr.cycle ; _ } = Level_storage.current ctxt in + credit_frozen_rewards ctxt delegate cycle amount + +let burn_rewards ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_rewards ctxt contract cycle >>=? fun old_amount -> + let new_amount = + match Tez_repr.(old_amount -? amount) with + | Error _ -> Tez_repr.zero + | Ok new_amount -> new_amount in + Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount >>= fun ctxt -> + return ctxt + + + +let unfreeze ctxt delegate cycle = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle >>=? fun deposit -> + get_frozen_fees ctxt contract cycle >>=? fun fees -> + get_frozen_rewards ctxt contract cycle >>=? fun rewards -> + Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + Lwt.return Tez_repr.(deposit +? fees) >>=? fun unfrozen_amount -> + Lwt.return Tez_repr.(unfrozen_amount +? rewards) >>=? fun unfrozen_amount -> + Lwt.return Tez_repr.(balance +? unfrozen_amount) >>=? fun balance -> + Storage.Contract.Balance.set ctxt contract balance >>=? fun ctxt -> + Roll_storage.Delegate.add_amount ctxt delegate rewards >>=? fun ctxt -> + Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt -> + Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt -> + Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt -> + return (ctxt, (cleanup_balance_updates + [(Deposits (delegate, cycle), Debited deposit) ; + (Fees (delegate, cycle), Debited fees) ; + (Rewards (delegate, cycle), Debited rewards) ; + (Contract (Contract_repr.implicit_contract delegate), Credited unfrozen_amount)])) + +let cycle_end ctxt last_cycle unrevealed = + let preserved = Constants_storage.preserved_cycles ctxt in + begin + match Cycle_repr.pred last_cycle with + | None -> return (ctxt,[]) + | Some revealed_cycle -> + List.fold_left + (fun acc (u : Nonce_storage.unrevealed) -> + acc >>=? fun (ctxt, balance_updates) -> + burn_fees + ctxt u.delegate revealed_cycle u.fees >>=? fun ctxt -> + burn_rewards + ctxt u.delegate revealed_cycle u.rewards >>=? fun ctxt -> + let bus = [(Fees (u.delegate, revealed_cycle), Debited u.fees); + (Rewards (u.delegate, revealed_cycle), Debited u.rewards)] in + return (ctxt, bus @ balance_updates)) + (return (ctxt,[])) unrevealed + end >>=? fun (ctxt, balance_updates) -> + match Cycle_repr.sub last_cycle preserved with + | None -> return (ctxt, balance_updates, []) + | Some unfrozen_cycle -> + Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle) + ~init:(Ok (ctxt, balance_updates)) + ~f:(fun delegate acc -> + Lwt.return acc >>=? fun (ctxt, bus) -> + unfreeze ctxt + delegate unfrozen_cycle >>=? fun (ctxt, balance_updates) -> + return (ctxt, balance_updates @ bus)) >>=? fun (ctxt, balance_updates) -> + Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle) >>= fun ctxt -> + Storage.Active_delegates_with_rolls.fold ctxt + ~init:(Ok (ctxt, [])) + ~f:(fun delegate acc -> + Lwt.return acc >>=? fun (ctxt, deactivated) -> + Storage.Contract.Delegate_desactivation.get ctxt + (Contract_repr.implicit_contract delegate) >>=? fun cycle -> + if Cycle_repr.(cycle <= last_cycle) then + Roll_storage.Delegate.set_inactive ctxt delegate >>=? fun ctxt -> + return (ctxt, delegate :: deactivated) + else + return (ctxt, deactivated)) >>=? fun (ctxt, deactivated) -> + return (ctxt, balance_updates, deactivated) + +let punish ctxt delegate cycle = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle >>=? fun deposit -> + get_frozen_fees ctxt contract cycle >>=? fun fees -> + get_frozen_rewards ctxt contract cycle >>=? fun rewards -> + Roll_storage.Delegate.remove_amount ctxt delegate deposit >>=? fun ctxt -> + Roll_storage.Delegate.remove_amount ctxt delegate fees >>=? fun ctxt -> + (* Rewards are not accounted in the delegate's rolls yet... *) + Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt -> + Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt -> + Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt -> + return (ctxt, { deposit ; fees ; rewards }) + + +let has_frozen_balance ctxt delegate cycle = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle >>=? fun deposit -> + if Tez_repr.(deposit <> zero) then return_true + else + get_frozen_fees ctxt contract cycle >>=? fun fees -> + if Tez_repr.(fees <> zero) then return_true + else + get_frozen_rewards ctxt contract cycle >>=? fun rewards -> + return Tez_repr.(rewards <> zero) + +let frozen_balance_by_cycle_encoding = + let open Data_encoding in + conv + (Cycle_repr.Map.bindings) + (List.fold_left + (fun m (c, b) -> Cycle_repr.Map.add c b m) + Cycle_repr.Map.empty) + (list (merge_objs + (obj1 (req "cycle" Cycle_repr.encoding)) + frozen_balance_encoding)) + +let empty_frozen_balance = + { deposit = Tez_repr.zero ; + fees = Tez_repr.zero ; + rewards = Tez_repr.zero } + +let frozen_balance_by_cycle ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + let map = Cycle_repr.Map.empty in + Storage.Contract.Frozen_deposits.fold + (ctxt, contract) ~init:map + ~f:(fun cycle amount map -> + Lwt.return + (Cycle_repr.Map.add cycle + { empty_frozen_balance with deposit = amount } map)) >>= fun map -> + Storage.Contract.Frozen_fees.fold + (ctxt, contract) ~init:map + ~f:(fun cycle amount map -> + let balance = + match Cycle_repr.Map.find_opt cycle map with + | None -> empty_frozen_balance + | Some balance -> balance in + Lwt.return + (Cycle_repr.Map.add cycle + { balance with fees = amount } map)) >>= fun map -> + Storage.Contract.Frozen_rewards.fold + (ctxt, contract) ~init:map + ~f:(fun cycle amount map -> + let balance = + match Cycle_repr.Map.find_opt cycle map with + | None -> empty_frozen_balance + | Some balance -> balance in + Lwt.return + (Cycle_repr.Map.add cycle + { balance with rewards = amount } map)) >>= fun map -> + Lwt.return map + +let frozen_balance ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + let balance = Ok Tez_repr.zero in + Storage.Contract.Frozen_deposits.fold + (ctxt, contract) ~init:balance + ~f:(fun _cycle amount acc -> + Lwt.return acc >>=? fun acc -> + Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance -> + Storage.Contract.Frozen_fees.fold + (ctxt, contract) ~init:balance + ~f:(fun _cycle amount acc -> + Lwt.return acc >>=? fun acc -> + Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance -> + Storage.Contract.Frozen_rewards.fold + (ctxt, contract) ~init:balance + ~f:(fun _cycle amount acc -> + Lwt.return acc >>=? fun acc -> + Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance -> + Lwt.return balance + +let full_balance ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + frozen_balance ctxt delegate >>=? fun frozen_balance -> + Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + Lwt.return Tez_repr.(frozen_balance +? balance) + +let deactivated = Roll_storage.Delegate.is_inactive + +let grace_period ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Delegate_desactivation.get ctxt contract + +let staking_balance ctxt delegate = + let token_per_rolls = Constants_storage.tokens_per_roll ctxt in + Roll_storage.get_rolls ctxt delegate >>=? fun rolls -> + Roll_storage.get_change ctxt delegate >>=? fun change -> + let rolls = Int64.of_int (List.length rolls) in + Lwt.return Tez_repr.(token_per_rolls *? rolls) >>=? fun balance -> + Lwt.return Tez_repr.(balance +? change) + +let delegated_balance ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + staking_balance ctxt delegate >>=? fun staking_balance -> + Storage.Contract.Balance.get ctxt contract >>= fun self_staking_balance -> + Storage.Contract.Frozen_deposits.fold + (ctxt, contract) ~init:self_staking_balance + ~f:(fun _cycle amount acc -> + Lwt.return acc >>=? fun acc -> + Lwt.return (Tez_repr.(acc +? amount))) >>= fun self_staking_balance -> + Storage.Contract.Frozen_fees.fold + (ctxt, contract) ~init:self_staking_balance + ~f:(fun _cycle amount acc -> + Lwt.return acc >>=? fun acc -> + Lwt.return (Tez_repr.(acc +? amount))) >>=? fun self_staking_balance -> + Lwt.return Tez_repr.(staking_balance -? self_staking_balance) + +let fold = Storage.Delegates.fold +let list = Storage.Delegates.elements diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli new file mode 100644 index 000000000..6f458403b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli @@ -0,0 +1,187 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Places where tezzies can be found in the ledger's state. *) +type balance = + | Contract of Contract_repr.t + | Rewards of Signature.Public_key_hash.t * Cycle_repr.t + | Fees of Signature.Public_key_hash.t * Cycle_repr.t + | Deposits of Signature.Public_key_hash.t * Cycle_repr.t + +(** A credit or debit of tezzies to a balance. *) +type balance_update = + | Debited of Tez_repr.t + | Credited of Tez_repr.t + +(** A list of balance updates. Duplicates may happen. *) +type balance_updates = (balance * balance_update) list + +val balance_updates_encoding : balance_updates Data_encoding.t + +(** Remove zero-valued balances from a list of updates. *) +val cleanup_balance_updates : balance_updates -> balance_updates + +type frozen_balance = { + deposit : Tez_repr.t ; + fees : Tez_repr.t ; + rewards : Tez_repr.t ; +} + +(** Is the contract eligible to delegation ? *) +val is_delegatable: + Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + +(** Allow to register a delegate when creating an account. *) +val init: + Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t + +(** Cleanup delegation when deleting a contract. *) +val remove: + Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t + +(** Reading the current delegate of a contract. *) +val get: + Raw_context.t -> Contract_repr.t -> + Signature.Public_key_hash.t option tzresult Lwt.t + +val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t + +(** Updating the delegate of a contract. + + When calling this function on an "implicit contract" this function + fails, unless when the registered delegate is the contract manager. + In the that case, the manager is now registered as a delegate. One + cannot unregister a delegate for now. The associate contract is + now 'undeletable'. *) +val set: + Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> + Raw_context.t tzresult Lwt.t + +(** Same as {!set} ignoring the [delegatable] flag. *) +val set_from_script: + Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> + Raw_context.t tzresult Lwt.t + +type error += + | Non_delegatable_contract of Contract_repr.contract (* `Permanent *) + | No_deletion of Signature.Public_key_hash.t (* `Permanent *) + | Active_delegate (* `Temporary *) + | Current_delegate (* `Temporary *) + | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *) + | Balance_too_low_for_deposit of + { delegate : Signature.Public_key_hash.t ; + deposit : Tez_repr.t ; + balance : Tez_repr.t } (* `Temporary *) + +(** Iterate on all registered delegates. *) +val fold: + Raw_context.t -> + init:'a -> + f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + +(** List all registered delegates. *) +val list: Raw_context.t -> Signature.Public_key_hash.t list Lwt.t + +(** Various functions to 'freeze' tokens. A frozen 'deposit' keeps its + associated rolls. When frozen, 'fees' may trigger new rolls + allocation. Rewards won't trigger new rolls allocation until + unfrozen. *) +val freeze_deposit: + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val freeze_fees: + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val freeze_rewards: + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +(** Trigger the context maintenance at the end of cycle 'n', i.e.: + unfreeze deposit/fees/rewards from 'n - preserved_cycle' ; punish the + provided unrevealed seeds (tipically seed from cycle 'n - 1'). + Returns a list of account with the amount that was unfrozen for each + and the list of deactivated delegates. *) +val cycle_end: + Raw_context.t -> Cycle_repr.t -> Nonce_storage.unrevealed list -> + (Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult Lwt.t + +(** Burn all then frozen deposit/fees/rewards for a delegate at a given + cycle. Returns the burned amounts. *) +val punish: + Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t -> + (Raw_context.t * frozen_balance) tzresult Lwt.t + +(** Has the given key some frozen tokens in its implicit contract? *) +val has_frozen_balance: + Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t -> + bool tzresult Lwt.t + +(** Returns the amount of frozen deposit, fees and rewards associated + to a given delegate. *) +val frozen_balance: + Raw_context.t -> Signature.Public_key_hash.t -> + Tez_repr.t tzresult Lwt.t + +val frozen_balance_encoding: frozen_balance Data_encoding.t +val frozen_balance_by_cycle_encoding: + frozen_balance Cycle_repr.Map.t Data_encoding.t + +(** Returns the amount of frozen deposit, fees and rewards associated + to a given delegate, indexed by the cycle by which at the end the + balance will be unfrozen. *) +val frozen_balance_by_cycle: + Raw_context.t -> Signature.Public_key_hash.t -> + frozen_balance Cycle_repr.Map.t Lwt.t + +(** Returns the full 'balance' of the implicit contract associated to + a given key, i.e. the sum of the spendable balance and of the + frozen balance. *) +val full_balance: + Raw_context.t -> Signature.Public_key_hash.t -> + Tez_repr.t tzresult Lwt.t + +val staking_balance: + Raw_context.t -> Signature.Public_key_hash.t -> + Tez_repr.t tzresult Lwt.t + +(** Returns the list of contract that delegated towards a given delegate *) +val delegated_contracts: + Raw_context.t -> Signature.Public_key_hash.t -> + Contract_hash.t list Lwt.t + +val delegated_balance: + Raw_context.t -> Signature.Public_key_hash.t -> + Tez_repr.t tzresult Lwt.t + +val deactivated: + Raw_context.t -> Signature.Public_key_hash.t -> + bool tzresult Lwt.t + +val grace_period: + Raw_context.t -> Signature.Public_key_hash.t -> + Cycle_repr.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune b/vendors/ligo-utils/tezos-protocol-alpha/dune new file mode 100644 index 000000000..a715d55fd --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune @@ -0,0 +1,20 @@ +;; -*- mode: dune; -*- + +(include dune.inc) + +(rule + (targets "dune.inc.gen") + (deps TEZOS_PROTOCOL (glob_files *.ml) (glob_files *.mli)) + (action + (run + %{libexec:tezos-protocol-compiler:replace} + %{libexec:tezos-protocol-compiler:dune_protocol.template} + "dune.inc.gen"))) + +(alias + (name runtest_dune_template) + (action (diff dune.inc dune.inc.gen))) + +(alias + (name runtest) + (deps (alias runtest_dune_template))) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune-project b/vendors/ligo-utils/tezos-protocol-alpha/dune-project new file mode 100644 index 000000000..6d415f3bf --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.10) +(name tezos-embedded-protocol-alpha) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune.inc b/vendors/ligo-utils/tezos-protocol-alpha/dune.inc new file mode 100644 index 000000000..f7bbe1136 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune.inc @@ -0,0 +1,109 @@ + + +; +; /!\ /!\ Do not modify this file /!\ /!\ +; +; but the original template in `tezos-protocol-compiler` +; + + +(rule + (targets environment.ml) + (action + (write-file %{targets} + "module Name = struct let name = \"alpha\" end +include Tezos_protocol_environment.MakeV1(Name)() +module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end +"))) + +(rule + (targets registerer.ml) + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml + (:src_dir TEZOS_PROTOCOL)) + (action + (with-stdout-to %{targets} + (chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "alpha"))))) + +(rule + (targets functor.ml) + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml + (:src_dir TEZOS_PROTOCOL)) + (action (with-stdout-to %{targets} + (chdir %{workspace_root} + (run %{bin:tezos-protocol-compiler.tezos-protocol-packer} %{src_dir}))))) + +(rule + (targets protocol.ml) + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml) + (action + (write-file %{targets} + "module Environment = Tezos_protocol_environment_alpha.Environment +let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK\" +let name = Environment.Name.name +include Tezos_raw_protocol_alpha +include Tezos_raw_protocol_alpha.Main +"))) + +(library + (name tezos_protocol_environment_alpha) + (public_name tezos-protocol-alpha.environment) + (library_flags (:standard -linkall)) + (libraries tezos-protocol-environment) + (modules Environment)) + +(library + (name tezos_raw_protocol_alpha) + (public_name tezos-protocol-alpha.raw) + (libraries tezos_protocol_environment_alpha) + (library_flags (:standard -linkall)) + (flags (:standard -nopervasives -nostdlib + -w +a-4-6-7-9-29-32-40..42-44-45-48 + -warn-error -a+8 + -open Tezos_protocol_environment_alpha__Environment + -open Pervasives + -open Error_monad)) + (modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main)) + +(install + (section lib) + (package tezos-protocol-alpha) + (files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL))) + +(library + (name tezos_protocol_alpha) + (public_name tezos-protocol-alpha) + (libraries + tezos-protocol-environment + tezos-protocol-environment-sigs + tezos_raw_protocol_alpha) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + -warn-error "-a+8" + -nopervasives) + (modules Protocol)) + +(library + (name tezos_protocol_alpha_functor) + (public_name tezos-protocol-alpha.functor) + (libraries + tezos-protocol-environment + tezos-protocol-environment-sigs + tezos_raw_protocol_alpha) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + -warn-error "-a+8" + -nopervasives) + (modules Functor)) + +(library + (name tezos_embedded_protocol_alpha) + (public_name tezos-embedded-protocol-alpha) + (library_flags (:standard -linkall)) + (libraries tezos-protocol-alpha + tezos-protocol-updater + tezos-protocol-environment) + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + -warn-error -a+8)) + (modules Registerer)) + +(alias + (name runtest_sandbox) + (deps .tezos_protocol_alpha.objs/native/tezos_protocol_alpha.cmx)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml new file mode 100644 index 000000000..e713d96f1 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml @@ -0,0 +1,111 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Cannot_pay_storage_fee (* `Temporary *) +type error += Operation_quota_exceeded (* `Temporary *) +type error += Storage_limit_too_high (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:"contract.cannot_pay_storage_fee" + ~title:"Cannot pay storage fee" + ~description:"The storage fee is higher than the contract balance" + ~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee") + Data_encoding.empty + (function Cannot_pay_storage_fee -> Some () | _ -> None) + (fun () -> Cannot_pay_storage_fee) ; + register_error_kind + `Temporary + ~id:"storage_exhausted.operation" + ~title: "Storage quota exceeded for the operation" + ~description: + "A script or one of its callee wrote more \ + bytes than the operation said it would" + Data_encoding.empty + (function Operation_quota_exceeded -> Some () | _ -> None) + (fun () -> Operation_quota_exceeded) ; + register_error_kind + `Permanent + ~id:"storage_limit_too_high" + ~title: "Storage limit out of protocol hard bounds" + ~description: + "A transaction tried to exceed the hard limit on storage" + empty + (function Storage_limit_too_high -> Some () | _ -> None) + (fun () -> Storage_limit_too_high) + +let origination_burn c = + let origination_size = Constants_storage.origination_size c in + let cost_per_byte = Constants_storage.cost_per_byte c in + (* the origination burn, measured in bytes *) + Lwt.return + Tez_repr.(cost_per_byte *? (Int64.of_int origination_size)) >>=? fun to_be_paid -> + return (Raw_context.update_allocated_contracts_count c, + to_be_paid) + +let record_paid_storage_space c contract = + Contract_storage.used_storage_space c contract >>=? fun size -> + Contract_storage.set_paid_storage_space_and_return_fees_to_pay c contract size >>=? fun (to_be_paid, c) -> + let c = Raw_context.update_storage_space_to_pay c to_be_paid in + let cost_per_byte = Constants_storage.cost_per_byte c in + Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 to_be_paid))) >>=? fun to_burn -> + return (c, size, to_be_paid, to_burn) + +let burn_storage_fees c ~storage_limit ~payer = + let origination_size = Constants_storage.origination_size c in + let c, storage_space_to_pay, allocated_contracts = + Raw_context.clear_storage_space_to_pay c in + let storage_space_for_allocated_contracts = + Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in + let consumed = + Z.add storage_space_to_pay storage_space_for_allocated_contracts in + let remaining = Z.sub storage_limit consumed in + if Compare.Z.(remaining < Z.zero) then + fail Operation_quota_exceeded + else + let cost_per_byte = Constants_storage.cost_per_byte c in + Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 consumed))) >>=? fun to_burn -> + (* Burning the fees... *) + if Tez_repr.(to_burn = Tez_repr.zero) then + (* If the payer was was deleted by transfering all its balance, and no space was used, + burning zero would fail *) + return c + else + trace Cannot_pay_storage_fee + (Contract_storage.must_exist c payer >>=? fun () -> + Contract_storage.spend_from_script c payer to_burn) >>=? fun c -> + return c + +let check_storage_limit c ~storage_limit = + if Compare.Z.(storage_limit > (Raw_context.constants c).hard_storage_limit_per_operation) + || Compare.Z.(storage_limit < Z.zero)then + error Storage_limit_too_high + else + ok () + +let start_counting_storage_fees c = + Raw_context.init_storage_space_to_pay c diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli new file mode 100644 index 000000000..f46f7df87 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli @@ -0,0 +1,46 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Cannot_pay_storage_fee (* `Temporary *) +type error += Operation_quota_exceeded (* `Temporary *) +type error += Storage_limit_too_high (* `Permanent *) + +(** Does not burn, only adds the burn to storage space to be paid *) +val origination_burn: + Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t + +(** The returned Tez quantity is for logging purpose only *) +val record_paid_storage_space: + Raw_context.t -> Contract_repr.t -> + (Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t + +val check_storage_limit: + Raw_context.t -> storage_limit:Z.t -> unit tzresult + +val start_counting_storage_fees : + Raw_context.t -> Raw_context.t + +val burn_storage_fees: + Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml new file mode 100644 index 000000000..9e4e4e688 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Invalid_fitness (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"invalid_fitness" + ~title:"Invalid fitness" + ~description:"Fitness representation should be exactly 8 bytes long." + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness") + Data_encoding.empty + (function Invalid_fitness -> Some () | _ -> None) + (fun () -> Invalid_fitness) + +let int64_to_bytes i = + let b = MBytes.create 8 in + MBytes.set_int64 b 0 i; + b + +let int64_of_bytes b = + if Compare.Int.(MBytes.length b <> 8) then + error Invalid_fitness + else + ok (MBytes.get_int64 b 0) + +let from_int64 fitness = + [ MBytes.of_string Constants_repr.version_number ; + int64_to_bytes fitness ] + +let to_int64 = function + | [ version ; + fitness ] + when Compare.String. + (MBytes.to_string version = Constants_repr.version_number) -> + int64_of_bytes fitness + | [] -> ok 0L + | _ -> error Invalid_fitness diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml new file mode 100644 index 000000000..e8853db8e --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let current = Raw_context.current_fitness +let increase ?(gap = 1) ctxt = + let fitness = current ctxt in + Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml new file mode 100644 index 000000000..27025d7d6 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml @@ -0,0 +1,208 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = + | Unaccounted + | Limited of { remaining : Z.t } + +type cost = + { allocations : Z.t ; + steps : Z.t ; + reads : Z.t ; + writes : Z.t ; + bytes_read : Z.t ; + bytes_written : Z.t } + +let encoding = + let open Data_encoding in + union + [ case (Tag 0) + ~title:"Limited" + z + (function Limited { remaining } -> Some remaining | _ -> None) + (fun remaining -> Limited { remaining }) ; + case (Tag 1) + ~title:"Unaccounted" + (constant "unaccounted") + (function Unaccounted -> Some () | _ -> None) + (fun () -> Unaccounted) ] + +let pp ppf = function + | Unaccounted -> + Format.fprintf ppf "unaccounted" + | Limited { remaining } -> + Format.fprintf ppf "%s units remaining" (Z.to_string remaining) + +let cost_encoding = + let open Data_encoding in + conv + (fun { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } -> + (allocations, steps, reads, writes, bytes_read, bytes_written)) + (fun (allocations, steps, reads, writes, bytes_read, bytes_written) -> + { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written }) + (obj6 + (req "allocations" z) + (req "steps" z) + (req "reads" z) + (req "writes" z) + (req "bytes_read" z) + (req "bytes_written" z)) + +let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } = + Format.fprintf ppf + "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))" + (Z.to_string steps) + (Z.to_string allocations) + (Z.to_string reads) + (Z.to_string bytes_read) + (Z.to_string writes) + (Z.to_string bytes_written) + +type error += Block_quota_exceeded (* `Temporary *) +type error += Operation_quota_exceeded (* `Temporary *) + +let allocation_weight = Z.of_int 2 +let step_weight = Z.of_int 1 +let read_base_weight = Z.of_int 100 +let write_base_weight = Z.of_int 160 +let byte_read_weight = Z.of_int 10 +let byte_written_weight = Z.of_int 15 + +let consume block_gas operation_gas cost = match operation_gas with + | Unaccounted -> ok (block_gas, Unaccounted) + | Limited { remaining } -> + let weighted_cost = + Z.add + (Z.add + (Z.mul allocation_weight cost.allocations) + (Z.mul step_weight cost.steps)) + (Z.add + (Z.add + (Z.mul read_base_weight cost.reads) + (Z.mul write_base_weight cost.writes)) + (Z.add + (Z.mul byte_read_weight cost.bytes_read) + (Z.mul byte_written_weight cost.bytes_written))) in + let remaining = + Z.sub remaining weighted_cost in + let block_remaining = + Z.sub block_gas weighted_cost in + if Compare.Z.(remaining < Z.zero) + then error Operation_quota_exceeded + else if Compare.Z.(block_remaining < Z.zero) + then error Block_quota_exceeded + else ok (block_remaining, Limited { remaining }) + +let check_enough block_gas operation_gas cost = + consume block_gas operation_gas cost + >|? fun (_block_remainig, _remaining) -> () + +let alloc_cost n = + { allocations = Z.of_int (n + 1) ; + steps = Z.zero ; + reads = Z.zero ; + writes = Z.zero ; + bytes_read = Z.zero ; + bytes_written = Z.zero } + +let alloc_bytes_cost n = + alloc_cost ((n + 7) / 8) + +let alloc_bits_cost n = + alloc_cost ((n + 63) / 64) + +let step_cost n = + { allocations = Z.zero ; + steps = Z.of_int n ; + reads = Z.zero ; + writes = Z.zero ; + bytes_read = Z.zero ; + bytes_written = Z.zero } + +let free = + { allocations = Z.zero ; + steps = Z.zero ; + reads = Z.zero ; + writes = Z.zero ; + bytes_read = Z.zero ; + bytes_written = Z.zero } + +let read_bytes_cost n = + { allocations = Z.zero ; + steps = Z.zero ; + reads = Z.one ; + writes = Z.zero ; + bytes_read = n ; + bytes_written = Z.zero } + +let write_bytes_cost n = + { allocations = Z.zero ; + steps = Z.zero ; + reads = Z.zero ; + writes = Z.one ; + bytes_read = Z.zero ; + bytes_written = n } + +let ( +@ ) x y = + { allocations = Z.add x.allocations y.allocations ; + steps = Z.add x.steps y.steps ; + reads = Z.add x.reads y.reads ; + writes = Z.add x.writes y.writes ; + bytes_read = Z.add x.bytes_read y.bytes_read ; + bytes_written = Z.add x.bytes_written y.bytes_written } + +let ( *@ ) x y = + { allocations = Z.mul (Z.of_int x) y.allocations ; + steps = Z.mul (Z.of_int x) y.steps ; + reads = Z.mul (Z.of_int x) y.reads ; + writes = Z.mul (Z.of_int x) y.writes ; + bytes_read = Z.mul (Z.of_int x) y.bytes_read ; + bytes_written = Z.mul (Z.of_int x) y.bytes_written } + +let alloc_mbytes_cost n = + alloc_cost 12 +@ alloc_bytes_cost n + +let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:"gas_exhausted.operation" + ~title: "Gas quota exceeded for the operation" + ~description: + "A script or one of its callee took more \ + time than the operation said it would" + empty + (function Operation_quota_exceeded -> Some () | _ -> None) + (fun () -> Operation_quota_exceeded) ; + register_error_kind + `Temporary + ~id:"gas_exhausted.block" + ~title: "Gas quota exceeded for the block" + ~description: + "The sum of gas consumed by all the operations in the block \ + exceeds the hard gas limit per block" + empty + (function Block_quota_exceeded -> Some () | _ -> None) + (fun () -> Block_quota_exceeded) ; diff --git a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli new file mode 100644 index 000000000..00db52353 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = + | Unaccounted + | Limited of { remaining : Z.t } + +val encoding : t Data_encoding.encoding +val pp : Format.formatter -> t -> unit + +type cost + +val cost_encoding : cost Data_encoding.encoding +val pp_cost : Format.formatter -> cost -> unit + +type error += Block_quota_exceeded (* `Temporary *) +type error += Operation_quota_exceeded (* `Temporary *) + +val consume : Z.t -> t -> cost -> (Z.t * t) tzresult +val check_enough : Z.t -> t -> cost -> unit tzresult + +val free : cost +val step_cost : int -> cost +val alloc_cost : int -> cost +val alloc_bytes_cost : int -> cost +val alloc_mbytes_cost : int -> cost +val alloc_bits_cost : int -> cost +val read_bytes_cost : Z.t -> cost +val write_bytes_cost : Z.t -> cost + +val ( *@ ) : int -> cost -> cost +val ( +@ ) : cost -> cost -> cost diff --git a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml new file mode 100644 index 000000000..727028507 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml @@ -0,0 +1,635 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type error += Cannot_parse_operation (* `Branch *) + +let () = + register_error_kind + `Branch + ~id:"operation.cannot_parse" + ~title:"Cannot parse operation" + ~description:"The operation is ill-formed \ + or for another protocol version" + ~pp:(fun ppf () -> + Format.fprintf ppf "The operation cannot be parsed") + Data_encoding.unit + (function Cannot_parse_operation -> Some () | _ -> None) + (fun () -> Cannot_parse_operation) + +let parse_operation (op: Operation.raw) = + match Data_encoding.Binary.of_bytes + Operation.protocol_data_encoding + op.proto with + | Some protocol_data -> + ok { shell = op.shell ; protocol_data } + | None -> error Cannot_parse_operation + +let path = RPC_path.(open_root / "helpers") + +module Scripts = struct + + module S = struct + + open Data_encoding + + let path = RPC_path.(path / "scripts") + + let run_code_input_encoding = + (obj7 + (req "script" Script.expr_encoding) + (req "storage" Script.expr_encoding) + (req "input" Script.expr_encoding) + (req "amount" Tez.encoding) + (opt "source" Contract.encoding) + (opt "payer" Contract.encoding) + (opt "gas" z)) + + let trace_encoding = + def "scripted.trace" @@ + (list @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req "stack" + (list + (obj2 + (req "item" (Script.expr_encoding)) + (opt "annot" string))))) + + let run_code = + RPC_service.post_service + ~description: "Run a piece of code in the current context" + ~query: RPC_query.empty + ~input: run_code_input_encoding + ~output: (obj3 + (req "storage" Script.expr_encoding) + (req "operations" (list Operation.internal_operation_encoding)) + (opt "big_map_diff" Contract.big_map_diff_encoding)) + RPC_path.(path / "run_code") + + let trace_code = + RPC_service.post_service + ~description: "Run a piece of code in the current context, \ + keeping a trace" + ~query: RPC_query.empty + ~input: run_code_input_encoding + ~output: (obj4 + (req "storage" Script.expr_encoding) + (req "operations" (list Operation.internal_operation_encoding)) + (req "trace" trace_encoding) + (opt "big_map_diff" Contract.big_map_diff_encoding)) + RPC_path.(path / "trace_code") + + let typecheck_code = + RPC_service.post_service + ~description: "Typecheck a piece of code in the current context" + ~query: RPC_query.empty + ~input: (obj2 + (req "program" Script.expr_encoding) + (opt "gas" z)) + ~output: (obj2 + (req "type_map" Script_tc_errors_registration.type_map_enc) + (req "gas" Gas.encoding)) + RPC_path.(path / "typecheck_code") + + let typecheck_data = + RPC_service.post_service + ~description: "Check that some data expression is well formed \ + and of a given type in the current context" + ~query: RPC_query.empty + ~input: (obj3 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (opt "gas" z)) + ~output: (obj1 (req "gas" Gas.encoding)) + RPC_path.(path / "typecheck_data") + + let pack_data = + RPC_service.post_service + ~description: "Computes the serialized version of some data expression \ + using the same algorithm as script instruction PACK" + + ~input: (obj3 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (opt "gas" z)) + ~output: (obj2 + (req "packed" bytes) + (req "gas" Gas.encoding)) + ~query: RPC_query.empty + RPC_path.(path / "pack_data") + + let run_operation = + RPC_service.post_service + ~description: + "Run an operation without signature checks" + ~query: RPC_query.empty + ~input: Operation.encoding + ~output: Apply_results.operation_data_and_metadata_encoding + RPC_path.(path / "run_operation") + + end + + let register () = + let open Services_registration in + let originate_dummy_contract ctxt script = + let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, dummy_contract) -> + let balance = match Tez.of_mutez 4_000_000_000_000L with + | Some balance -> balance + | None -> assert false in + Contract.originate ctxt dummy_contract + ~balance + ~manager: Signature.Public_key_hash.zero + ~delegate: None + ~spendable: false + ~delegatable: false + ~script: (script, None) >>=? fun ctxt -> + return (ctxt, dummy_contract) in + register0 S.run_code begin fun ctxt () + (code, storage, parameter, amount, source, payer, gas) -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> + let source, payer = match source, payer with + | Some source, Some payer -> source, payer + | Some source, None -> source, source + | None, Some payer -> payer, payer + | None, None -> dummy_contract, dummy_contract in + let gas = match gas with + | Some gas -> gas + | None -> Constants.hard_gas_limit_per_operation ctxt in + let ctxt = Gas.set_limit ctxt gas in + Script_interpreter.execute + ctxt Readable + ~source + ~payer + ~self:(dummy_contract, { storage ; code }) + ~amount ~parameter + >>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } -> + return (storage, operations, big_map_diff) + end ; + register0 S.trace_code begin fun ctxt () + (code, storage, parameter, amount, source, payer, gas) -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> + let source, payer = match source, payer with + | Some source, Some payer -> source, payer + | Some source, None -> source, source + | None, Some payer -> payer, payer + | None, None -> dummy_contract, dummy_contract in + let gas = match gas with + | Some gas -> gas + | None -> Constants.hard_gas_limit_per_operation ctxt in + let ctxt = Gas.set_limit ctxt gas in + Script_interpreter.trace + ctxt Readable + ~source + ~payer + ~self:(dummy_contract, { storage ; code }) + ~amount ~parameter + >>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) -> + return (storage, operations, trace, big_map_diff) + end ; + register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) -> + let ctxt = match maybe_gas with + | None -> Gas.set_unlimited ctxt + | Some gas -> Gas.set_limit ctxt gas in + Script_ir_translator.typecheck_code ctxt expr >>=? fun (res, ctxt) -> + return (res, Gas.level ctxt) + end ; + register0 S.typecheck_data begin fun ctxt () (data, ty, maybe_gas) -> + let ctxt = match maybe_gas with + | None -> Gas.set_unlimited ctxt + | Some gas -> Gas.set_limit ctxt gas in + Script_ir_translator.typecheck_data ctxt (data, ty) >>=? fun ctxt -> + return (Gas.level ctxt) + end ; + register0 S.pack_data begin fun ctxt () (expr, typ, maybe_gas) -> + let open Script_ir_translator in + let ctxt = match maybe_gas with + | None -> Gas.set_unlimited ctxt + | Some gas -> Gas.set_limit ctxt gas in + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) -> + parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> + Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) -> + return (bytes, Gas.level ctxt) + end ; + register0 S.run_operation begin fun ctxt () + { shell ; protocol_data = Operation_data protocol_data } -> + (* this code is a duplicate of Apply without signature check *) + let partial_precheck_manager_contents + (type kind) ctxt (op : kind Kind.manager contents) + : context tzresult Lwt.t = + let Manager_operation { source ; fee ; counter ; operation ; gas_limit ; storage_limit } = op in + Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> + let ctxt = Gas.set_limit ctxt gas_limit in + Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> + Contract.must_be_allocated ctxt source >>=? fun () -> + Contract.check_counter_increment ctxt source counter >>=? fun () -> + begin + match operation with + | Reveal pk -> + Contract.reveal_manager_key ctxt source pk + | Transaction { parameters = Some arg ; _ } -> + (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) + let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding arg in + let arg = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with + | Some arg -> arg + | None -> assert false in + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return @@ record_trace Apply.Gas_quota_exceeded_init_deserialize @@ + Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + trace Apply.Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt + | Origination { script = Some script ; _ } -> + (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) + let script_bytes = Data_encoding.Binary.to_bytes_exn Script.encoding script in + let script = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with + | Some script -> script + | None -> assert false in + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return @@ record_trace Apply.Gas_quota_exceeded_init_deserialize @@ + (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + trace Apply.Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt script.code >>=? fun (_code, ctxt) -> + trace Apply.Gas_quota_exceeded_init_deserialize @@ + Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) -> ctxt + | _ -> return ctxt + end >>=? fun ctxt -> + Contract.get_manager_key ctxt source >>=? fun _public_key -> + (* signature check unplugged from here *) + Contract.increment_counter ctxt source >>=? fun ctxt -> + Contract.spend ctxt source fee >>=? fun ctxt -> + return ctxt in + let rec partial_precheck_manager_contents_list + : type kind. + Alpha_context.t -> kind Kind.manager contents_list -> + context tzresult Lwt.t = + fun ctxt contents_list -> + match contents_list with + | Single (Manager_operation _ as op) -> + partial_precheck_manager_contents ctxt op + | Cons (Manager_operation _ as op, rest) -> + partial_precheck_manager_contents ctxt op >>=? fun ctxt -> + partial_precheck_manager_contents_list ctxt rest in + let return contents = + return (Operation_data protocol_data, + Apply_results.Operation_metadata { contents }) in + let operation : _ operation = { shell ; protocol_data } in + let hash = Operation.hash { shell ; protocol_data } in + let ctxt = Contract.init_origination_nonce ctxt hash in + let baker = Signature.Public_key_hash.zero in + match protocol_data.contents with + | Single (Manager_operation _) as op -> + partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> + Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) -> + return result + | Cons (Manager_operation _, _) as op -> + partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> + Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) -> + return result + | _ -> + Apply.apply_contents_list + ctxt ~partial:true Chain_id.zero Optimized shell.branch baker operation + operation.protocol_data.contents >>=? fun (_ctxt, result) -> + return result + + end + + let run_code ctxt block code (storage, input, amount, source, payer, gas) = + RPC_context.make_call0 S.run_code ctxt + block () (code, storage, input, amount, source, payer, gas) + + let trace_code ctxt block code (storage, input, amount, source, payer, gas) = + RPC_context.make_call0 S.trace_code ctxt + block () (code, storage, input, amount, source, payer, gas) + + let typecheck_code ctxt block = + RPC_context.make_call0 S.typecheck_code ctxt block () + + let typecheck_data ctxt block = + RPC_context.make_call0 S.typecheck_data ctxt block () + + let pack_data ctxt block = + RPC_context.make_call0 S.pack_data ctxt block () + + let run_operation ctxt block = + RPC_context.make_call0 S.run_operation ctxt block () + +end + +module Forge = struct + + module S = struct + + open Data_encoding + + let path = RPC_path.(path / "forge") + + let operations = + RPC_service.post_service + ~description:"Forge an operation" + ~query: RPC_query.empty + ~input: Operation.unsigned_encoding + ~output: bytes + RPC_path.(path / "operations" ) + + let empty_proof_of_work_nonce = + MBytes.of_string + (String.make Constants_repr.proof_of_work_nonce_size '\000') + + let protocol_data = + RPC_service.post_service + ~description: "Forge the protocol-specific part of a block header" + ~query: RPC_query.empty + ~input: + (obj3 + (req "priority" uint16) + (opt "nonce_hash" Nonce_hash.encoding) + (dft "proof_of_work_nonce" + (Fixed.bytes + Alpha_context.Constants.proof_of_work_nonce_size) + empty_proof_of_work_nonce)) + ~output: (obj1 (req "protocol_data" bytes)) + RPC_path.(path / "protocol_data") + + end + + let register () = + let open Services_registration in + register0_noctxt S.operations begin fun () (shell, proto) -> + return (Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding (shell, proto)) + end ; + register0_noctxt S.protocol_data begin fun () + (priority, seed_nonce_hash, proof_of_work_nonce) -> + return (Data_encoding.Binary.to_bytes_exn + Block_header.contents_encoding + { priority ; seed_nonce_hash ; proof_of_work_nonce }) + end + + module Manager = struct + + let operations ctxt + block ~branch ~source ?sourcePubKey ~counter ~fee + ~gas_limit ~storage_limit operations = + Contract_services.manager_key ctxt block source >>= function + | Error _ as e -> Lwt.return e + | Ok (_, revealed) -> + let ops = + List.map + (fun (Manager operation) -> + Contents + (Manager_operation { source ; + counter ; operation ; fee ; + gas_limit ; storage_limit })) + operations in + let ops = + match sourcePubKey, revealed with + | None, _ | _, Some _ -> ops + | Some pk, None -> + let operation = Reveal pk in + Contents + (Manager_operation { source ; + counter ; operation ; fee ; + gas_limit ; storage_limit }) :: ops in + RPC_context.make_call0 S.operations ctxt block + () ({ branch }, Operation.of_list ops) + + let reveal ctxt + block ~branch ~source ~sourcePubKey ~counter ~fee () = + operations ctxt block ~branch ~source ~sourcePubKey ~counter ~fee + ~gas_limit:Z.zero ~storage_limit:Z.zero [] + + let transaction ctxt + block ~branch ~source ?sourcePubKey ~counter + ~amount ~destination ?parameters + ~gas_limit ~storage_limit ~fee ()= + let parameters = Option.map ~f:Script.lazy_expr parameters in + operations ctxt block ~branch ~source ?sourcePubKey ~counter + ~fee ~gas_limit ~storage_limit + [Manager (Transaction { amount ; parameters ; destination })] + + let origination ctxt + block ~branch + ~source ?sourcePubKey ~counter + ~managerPubKey ~balance + ?(spendable = true) + ?(delegatable = true) + ?delegatePubKey ?script + ~gas_limit ~storage_limit ~fee () = + operations ctxt block ~branch ~source ?sourcePubKey ~counter + ~fee ~gas_limit ~storage_limit + [Manager (Origination { manager = managerPubKey ; + delegate = delegatePubKey ; + script ; + spendable ; + delegatable ; + credit = balance ; + preorigination = None })] + + let delegation ctxt + block ~branch ~source ?sourcePubKey ~counter ~fee delegate = + operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + ~gas_limit:Z.zero ~storage_limit:Z.zero + [Manager (Delegation delegate)] + + end + + let operation ctxt + block ~branch operation = + RPC_context.make_call0 S.operations ctxt block + () ({ branch }, Contents_list (Single operation)) + + let endorsement ctxt + b ~branch ~level () = + operation ctxt b ~branch + (Endorsement { level }) + + let proposals ctxt + b ~branch ~source ~period ~proposals () = + operation ctxt b ~branch + (Proposals { source ; period ; proposals }) + + let ballot ctxt + b ~branch ~source ~period ~proposal ~ballot () = + operation ctxt b ~branch + (Ballot { source ; period ; proposal ; ballot }) + + let seed_nonce_revelation ctxt + block ~branch ~level ~nonce () = + operation ctxt block ~branch (Seed_nonce_revelation { level ; nonce }) + + let double_baking_evidence ctxt + block ~branch ~bh1 ~bh2 () = + operation ctxt block ~branch (Double_baking_evidence { bh1 ; bh2 }) + + let double_endorsement_evidence ctxt + block ~branch ~op1 ~op2 () = + operation ctxt block ~branch (Double_endorsement_evidence { op1 ; op2 }) + + let empty_proof_of_work_nonce = + MBytes.of_string + (String.make Constants_repr.proof_of_work_nonce_size '\000') + + let protocol_data ctxt + block + ~priority ?seed_nonce_hash + ?(proof_of_work_nonce = empty_proof_of_work_nonce) + () = + RPC_context.make_call0 S.protocol_data + ctxt block () (priority, seed_nonce_hash, proof_of_work_nonce) + +end + +module Parse = struct + + module S = struct + + open Data_encoding + + let path = RPC_path.(path / "parse") + + let operations = + RPC_service.post_service + ~description:"Parse operations" + ~query: RPC_query.empty + ~input: + (obj2 + (req "operations" (list (dynamic_size Operation.raw_encoding))) + (opt "check_signature" bool)) + ~output: (list (dynamic_size Operation.encoding)) + RPC_path.(path / "operations" ) + + let block = + RPC_service.post_service + ~description:"Parse a block" + ~query: RPC_query.empty + ~input: Block_header.raw_encoding + ~output: Block_header.protocol_data_encoding + RPC_path.(path / "block" ) + + end + + let parse_protocol_data protocol_data = + match + Data_encoding.Binary.of_bytes + Block_header.protocol_data_encoding + protocol_data + with + | None -> failwith "Cant_parse_protocol_data" + | Some protocol_data -> return protocol_data + + let register () = + let open Services_registration in + register0 S.operations begin fun _ctxt () (operations, check) -> + map_s begin fun raw -> + Lwt.return (parse_operation raw) >>=? fun op -> + begin match check with + | Some true -> + return_unit (* FIXME *) + (* I.check_signature ctxt *) + (* op.protocol_data.signature op.shell op.protocol_data.contents *) + | Some false | None -> return_unit + end >>|? fun () -> op + end operations + end ; + register0_noctxt S.block begin fun () raw_block -> + parse_protocol_data raw_block.protocol_data + end + + let operations ctxt block ?check operations = + RPC_context.make_call0 + S.operations ctxt block () (operations, check) + let block ctxt block shell protocol_data = + RPC_context.make_call0 + S.block ctxt block () ({ shell ; protocol_data } : Block_header.raw) + +end + +module S = struct + + open Data_encoding + + type level_query = { + offset: int32 ; + } + let level_query : level_query RPC_query.t = + let open RPC_query in + query (fun offset -> { offset }) + |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset) + |> seal + + let current_level = + RPC_service.get_service + ~description: + "Returns the level of the interrogated block, or the one of a \ + block located `offset` blocks after in the chain (or before \ + when negative). For instance, the next block if `offset` is 1." + ~query: level_query + ~output: Level.encoding + RPC_path.(path / "current_level") + + let levels_in_current_cycle = + RPC_service.get_service + ~description: "Levels of a cycle" + ~query: level_query + ~output: (obj2 + (req "first" Raw_level.encoding) + (req "last" Raw_level.encoding)) + RPC_path.(path / "levels_in_current_cycle") + +end + +let register () = + Scripts.register () ; + Forge.register () ; + Parse.register () ; + let open Services_registration in + register0 S.current_level begin fun ctxt q () -> + let level = Level.current ctxt in + return (Level.from_raw ctxt ~offset:q.offset level.level) + end ; + register0 S.levels_in_current_cycle begin fun ctxt q () -> + let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in + match levels with + | [] -> raise Not_found + | _ -> + let first = List.hd (List.rev levels) in + let last = List.hd levels in + return (first.level, last.level) + end + +let current_level ctxt ?(offset = 0l) block = + RPC_context.make_call0 S.current_level ctxt block { offset } () + +let levels_in_current_cycle ctxt ?(offset = 0l) block = + RPC_context.make_call0 S.levels_in_current_cycle ctxt block { offset } () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli new file mode 100644 index 000000000..060323063 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli @@ -0,0 +1,211 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type error += Cannot_parse_operation (* `Branch *) + +val current_level: + 'a #RPC_context.simple -> + ?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t + +val levels_in_current_cycle: + 'a #RPC_context.simple -> + ?offset:int32 -> 'a -> (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t + +module Scripts : sig + + val run_code: + 'a #RPC_context.simple -> + 'a -> Script.expr -> + (Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option * Z.t option) -> + (Script.expr * + packed_internal_operation list * + Contract.big_map_diff option) shell_tzresult Lwt.t + + val trace_code: + 'a #RPC_context.simple -> + 'a -> Script.expr -> + (Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option* Z.t option) -> + (Script.expr * + packed_internal_operation list * + Script_interpreter.execution_trace * + Contract.big_map_diff option) shell_tzresult Lwt.t + + val typecheck_code: + 'a #RPC_context.simple -> + 'a -> (Script.expr * Z.t option) -> + (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t + + val typecheck_data: + 'a #RPC_context.simple -> + 'a -> Script.expr * Script.expr * Z.t option -> Gas.t shell_tzresult Lwt.t + + val pack_data: + 'a #RPC_context.simple -> + 'a -> Script.expr * Script.expr * Z.t option -> (MBytes.t * Gas.t) shell_tzresult Lwt.t + + val run_operation: + 'a #RPC_context.simple -> + 'a -> packed_operation -> + (packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t + +end + +module Forge : sig + + module Manager : sig + + val operations: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:counter -> + fee:Tez.t -> + gas_limit:Z.t -> + storage_limit:Z.t -> + packed_manager_operation list -> MBytes.t shell_tzresult Lwt.t + + val reveal: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + sourcePubKey:public_key -> + counter:counter -> + fee:Tez.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val transaction: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:counter -> + amount:Tez.t -> + destination:Contract.t -> + ?parameters:Script.expr -> + gas_limit:Z.t -> + storage_limit:Z.t -> + fee:Tez.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val origination: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:counter -> + managerPubKey:public_key_hash -> + balance:Tez.t -> + ?spendable:bool -> + ?delegatable:bool -> + ?delegatePubKey: public_key_hash -> + ?script:Script.t -> + gas_limit:Z.t -> + storage_limit:Z.t -> + fee:Tez.t-> + unit -> MBytes.t shell_tzresult Lwt.t + + val delegation: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:counter -> + fee:Tez.t -> + public_key_hash option -> + MBytes.t shell_tzresult Lwt.t + + end + + val endorsement: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + level:Raw_level.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val proposals: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + period:Voting_period.t -> + proposals:Protocol_hash.t list -> + unit -> MBytes.t shell_tzresult Lwt.t + + val ballot: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + period:Voting_period.t -> + proposal:Protocol_hash.t -> + ballot:Vote.ballot -> + unit -> MBytes.t shell_tzresult Lwt.t + + val seed_nonce_revelation: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + level:Raw_level.t -> + nonce:Nonce.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val double_baking_evidence: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + bh1: Block_header.t -> + bh2: Block_header.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val double_endorsement_evidence: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + op1: Kind.endorsement operation -> + op2: Kind.endorsement operation -> + unit -> MBytes.t shell_tzresult Lwt.t + + val protocol_data: + 'a #RPC_context.simple -> 'a -> + priority: int -> + ?seed_nonce_hash: Nonce_hash.t -> + ?proof_of_work_nonce: MBytes.t -> + unit -> MBytes.t shell_tzresult Lwt.t + +end + +module Parse : sig + + val operations: + 'a #RPC_context.simple -> 'a -> + ?check:bool -> Operation.raw list -> + Operation.packed list shell_tzresult Lwt.t + + val block: + 'a #RPC_context.simple -> 'a -> + Block_header.shell_header -> MBytes.t -> + Block_header.protocol_data shell_tzresult Lwt.t + +end + +val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml new file mode 100644 index 000000000..9d313def8 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* This is the genesis protocol: initialise the state *) +let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = + Raw_context.prepare_first_block + ~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) -> + match previous_protocol with + | Genesis param -> + Commitment_storage.init ctxt param.commitments >>=? fun ctxt -> + Roll_storage.init ctxt >>=? fun ctxt -> + Seed_storage.init ctxt >>=? fun ctxt -> + Contract_storage.init ctxt >>=? fun ctxt -> + Bootstrap_storage.init ctxt + ~typecheck + ?ramp_up_cycles:param.security_deposit_ramp_up_cycles + ?no_reward_cycles:param.no_reward_cycles + param.bootstrap_accounts + param.bootstrap_contracts >>=? fun ctxt -> + Roll_storage.init_first_cycles ctxt >>=? fun ctxt -> + Vote_storage.init ctxt >>=? fun ctxt -> + Storage.Last_block_priority.init ctxt 0 >>=? fun ctxt -> + Vote_storage.freeze_listings ctxt >>=? fun ctxt -> + return ctxt + | Alpha_previous -> + return ctxt + +let prepare ctxt ~level ~timestamp ~fitness = + Raw_context.prepare ~level ~timestamp ~fitness ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml new file mode 100644 index 000000000..957e58883 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml @@ -0,0 +1,148 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + level: Raw_level_repr.t ; + level_position: int32 ; + cycle: Cycle_repr.t ; + cycle_position: int32 ; + voting_period: Voting_period_repr.t ; + voting_period_position: int32 ; + expected_commitment: bool ; +} + +include Compare.Make(struct + type nonrec t = t + let compare { level = l1 } { level = l2 } = Raw_level_repr.compare l1 l2 + end) + +type level = t + +let pp ppf { level } = Raw_level_repr.pp ppf level + +let pp_full ppf l = + Format.fprintf ppf + "%a.%ld (cycle %a.%ld) (vote %a.%ld)" + Raw_level_repr.pp l.level l.level_position + Cycle_repr.pp l.cycle l.cycle_position + Voting_period_repr.pp l.voting_period l.voting_period_position + +let encoding = + let open Data_encoding in + conv + (fun { level ; level_position ; + cycle ; cycle_position ; + voting_period; voting_period_position ; + expected_commitment } -> + (level, level_position, + cycle, cycle_position, + voting_period, voting_period_position, + expected_commitment)) + (fun (level, level_position, + cycle, cycle_position, + voting_period, voting_period_position, + expected_commitment) -> + { level ; level_position ; + cycle ; cycle_position ; + voting_period ; voting_period_position ; + expected_commitment }) + (obj7 + (req "level" + ~description: + "The level of the block relative to genesis. This is also \ + the Shell's notion of level" + Raw_level_repr.encoding) + (req "level_position" + ~description: + "The level of the block relative to the block that starts \ + protocol alpha. This is specific to the protocol \ + alpha. Other protocols might or might not include a \ + similar notion." + int32) + (req "cycle" + ~description: + "The current cycle's number. Note that cycles are a \ + protocol-specific notion. As a result, the cycle number starts at 0 \ + with the first block of protocol alpha." + Cycle_repr.encoding) + (req "cycle_position" + ~description: + "The current level of the block relative to the first \ + block of the current cycle." + int32) + (req "voting_period" + ~description: + "The current voting period's index. Note that cycles are a \ + protocol-specific notion. As a result, the voting period \ + index starts at 0 with the first block of protocol alpha." + Voting_period_repr.encoding) + (req "voting_period_position" + ~description: + "The current level of the block relative to the first \ + block of the current voting period." + int32) + (req "expected_commitment" + ~description: + "Tells wether the baker of this block has to commit a seed \ + nonce hash." + bool)) + +let root first_level = + { level = first_level ; + level_position = 0l ; + cycle = Cycle_repr.root ; + cycle_position = 0l ; + voting_period = Voting_period_repr.root ; + voting_period_position = 0l ; + expected_commitment = false ; + } + +let from_raw + ~first_level ~blocks_per_cycle ~blocks_per_voting_period + ~blocks_per_commitment + level = + let raw_level = Raw_level_repr.to_int32 level in + let first_level = Raw_level_repr.to_int32 first_level in + let level_position = + Compare.Int32.max 0l (Int32.sub raw_level first_level) in + let cycle = + Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in + let cycle_position = Int32.rem level_position blocks_per_cycle in + let voting_period = + Voting_period_repr.of_int32_exn + (Int32.div level_position blocks_per_voting_period) in + let voting_period_position = + Int32.rem level_position blocks_per_voting_period in + let expected_commitment = + Compare.Int32.(Int32.rem cycle_position blocks_per_commitment = + Int32.pred blocks_per_commitment) in + { level ; level_position ; + cycle ; cycle_position ; + voting_period ; voting_period_position ; + expected_commitment } + +let diff { level = l1 ; _ } { level = l2 ; _ } = + Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2) + diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli new file mode 100644 index 000000000..d0ac31664 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli @@ -0,0 +1,69 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = private { + level: Raw_level_repr.t (** The level of the block relative to genesis. This + is also the Shell's notion of level. *); + level_position: int32 (** The level of the block relative to the block that + starts protocol alpha. This is specific to the + protocol alpha. Other protocols might or might not + include a similar notion. *); + cycle: Cycle_repr.t (** The current cycle's number. Note that cycles are a + protocol-specific notion. As a result, the cycle + number starts at 0 with the first block of protocol + alpha. *); + cycle_position: int32 (** The current level of the block relative to the first + block of the current cycle. *); + voting_period: Voting_period_repr.t ; + voting_period_position: int32 ; + expected_commitment: bool ; +} + +(* Note that, the type `t` above must respect some invariants (hence the + `private` annotation). Notably: + + level_position = cycle * blocks_per_cycle + cycle_position +*) + + + +type level = t + +include Compare.S with type t := level + +val encoding: level Data_encoding.t +val pp: Format.formatter -> level -> unit +val pp_full: Format.formatter -> level -> unit + +val root: Raw_level_repr.t -> level + +val from_raw: + first_level:Raw_level_repr.t -> + blocks_per_cycle:int32 -> + blocks_per_voting_period:int32 -> + blocks_per_commitment:int32 -> + Raw_level_repr.t -> level + +val diff: level -> level -> int32 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml new file mode 100644 index 000000000..956234416 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml @@ -0,0 +1,112 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Level_repr + +let from_raw c ?offset l = + let l = + match offset with + | None -> l + | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in + let constants = Raw_context.constants c in + let first_level = Raw_context.first_level c in + Level_repr.from_raw + ~first_level + ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle + ~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period + ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment + l + +let root c = + Level_repr.root (Raw_context.first_level c) + +let succ c l = from_raw c (Raw_level_repr.succ l.level) +let pred c l = + match Raw_level_repr.pred l.Level_repr.level with + | None -> None + | Some l -> Some (from_raw c l) + +let current ctxt = Raw_context.current_level ctxt + +let previous ctxt = + let l = current ctxt in + match pred ctxt l with + | None -> assert false (* We never validate the Genesis... *) + | Some p -> p + +let first_level_in_cycle ctxt c = + let constants = Raw_context.constants ctxt in + let first_level = Raw_context.first_level ctxt in + from_raw ctxt + (Raw_level_repr.of_int32_exn + (Int32.add + (Raw_level_repr.to_int32 first_level) + (Int32.mul + constants.Constants_repr.blocks_per_cycle + (Cycle_repr.to_int32 c)))) + +let last_level_in_cycle ctxt c = + match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with + | None -> assert false + | Some x -> x + +let levels_in_cycle ctxt cycle = + let first = first_level_in_cycle ctxt cycle in + let rec loop n acc = + if Cycle_repr.(n.cycle = first.cycle) + then loop (succ ctxt n) (n :: acc) + else acc + in + loop first [] + +let levels_in_current_cycle ctxt ?(offset = 0l) () = + let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in + let cycle = Int32.add current_cycle offset in + if Compare.Int32.(cycle < 0l) then + [] + else + let cycle = Cycle_repr.of_int32_exn cycle in + levels_in_cycle ctxt cycle + +let levels_with_commitments_in_cycle ctxt c = + let first = first_level_in_cycle ctxt c in + let rec loop n acc = + if Cycle_repr.(n.cycle = first.cycle) + then + if n.expected_commitment then + loop (succ ctxt n) (n :: acc) + else + loop (succ ctxt n) acc + else acc + in + loop first [] + + +let last_allowed_fork_level c = + let level = Raw_context.current_level c in + let preserved_cycles = Constants_storage.preserved_cycles c in + match Cycle_repr.sub level.cycle preserved_cycles with + | None -> Raw_level_repr.root + | Some cycle -> (first_level_in_cycle c cycle).level diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli new file mode 100644 index 000000000..03b2c2991 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val current: Raw_context.t -> Level_repr.t +val previous: Raw_context.t -> Level_repr.t + +val root: Raw_context.t -> Level_repr.t + +val from_raw: Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t +val pred: Raw_context.t -> Level_repr.t -> Level_repr.t option +val succ: Raw_context.t -> Level_repr.t -> Level_repr.t + +val first_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t +val last_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t +val levels_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t list +val levels_in_current_cycle: + Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list + +val levels_with_commitments_in_cycle: + Raw_context.t -> Cycle_repr.t -> Level_repr.t list + +val last_allowed_fork_level: Raw_context.t -> Raw_level_repr.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/main.ml b/vendors/ligo-utils/tezos-protocol-alpha/main.ml new file mode 100644 index 000000000..ec05389ca --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/main.ml @@ -0,0 +1,308 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Protocol Signature Instance *) + +type block_header_data = Alpha_context.Block_header.protocol_data +type block_header = Alpha_context.Block_header.t = { + shell: Block_header.shell_header ; + protocol_data: block_header_data ; +} + +let block_header_data_encoding = Alpha_context.Block_header.protocol_data_encoding + +type block_header_metadata = Apply_results.block_metadata +let block_header_metadata_encoding = Apply_results.block_metadata_encoding + +type operation_data = Alpha_context.packed_protocol_data = + | Operation_data : 'kind Alpha_context.Operation.protocol_data -> operation_data +let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding + +type operation_receipt = Apply_results.packed_operation_metadata = + | Operation_metadata : 'kind Apply_results.operation_metadata -> operation_receipt + | No_operation_metadata: operation_receipt +let operation_receipt_encoding = + Apply_results.operation_metadata_encoding + +let operation_data_and_receipt_encoding = + Apply_results.operation_data_and_metadata_encoding + +type operation = Alpha_context.packed_operation = { + shell: Operation.shell_header ; + protocol_data: operation_data ; +} + + +let acceptable_passes = Alpha_context.Operation.acceptable_passes + +let max_block_length = + Alpha_context.Block_header.max_header_length + +let max_operation_data_length = + Alpha_context.Constants.max_operation_data_length + +let validation_passes = + let max_anonymous_operations = + Alpha_context.Constants.max_revelations_per_block + + (* allow 100 wallet activations or denunciations per block *) 100 in + Updater.[ { max_size = 32 * 1024 ; max_op = Some 32 } ; (* 32 endorsements *) + { max_size = 32 * 1024 ; max_op = None } ; (* 32k of voting operations *) + { max_size = max_anonymous_operations * 1024 ; + max_op = Some max_anonymous_operations } ; + { max_size = 512 * 1024 ; max_op = None } ] (* 512kB *) + +let rpc_services = + Alpha_services.register () ; + Services_registration.get_rpc_services () + +type validation_mode = + | Application of { + block_header : Alpha_context.Block_header.t ; + baker : Alpha_context.public_key_hash ; + } + | Partial_application of { + block_header : Alpha_context.Block_header.t ; + baker : Alpha_context.public_key_hash ; + } + | Partial_construction of { + predecessor : Block_hash.t ; + } + | Full_construction of { + predecessor : Block_hash.t ; + protocol_data : Alpha_context.Block_header.contents ; + baker : Alpha_context.public_key_hash ; + } + +type validation_state = + { mode : validation_mode ; + chain_id : Chain_id.t ; + ctxt : Alpha_context.t ; + op_count : int ; + } + +let current_context { ctxt ; _ } = + return (Alpha_context.finalize ctxt).context + +let begin_partial_application + ~chain_id + ~ancestor_context:ctxt + ~predecessor_timestamp + ~predecessor_fitness + (block_header : Alpha_context.Block_header.t) = + let level = block_header.shell.level in + let fitness = predecessor_fitness in + let timestamp = block_header.shell.timestamp in + Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + Apply.begin_application + ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) -> + let mode = + Partial_application + { block_header ; baker = Signature.Public_key.hash baker } in + return { mode ; chain_id ; ctxt ; op_count = 0 } + +let begin_application + ~chain_id + ~predecessor_context:ctxt + ~predecessor_timestamp + ~predecessor_fitness + (block_header : Alpha_context.Block_header.t) = + let level = block_header.shell.level in + let fitness = predecessor_fitness in + let timestamp = block_header.shell.timestamp in + Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + Apply.begin_application + ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) -> + let mode = Application { block_header ; baker = Signature.Public_key.hash baker } in + return { mode ; chain_id ; ctxt ; op_count = 0 } + +let begin_construction + ~chain_id + ~predecessor_context:ctxt + ~predecessor_timestamp:pred_timestamp + ~predecessor_level:pred_level + ~predecessor_fitness:pred_fitness + ~predecessor + ~timestamp + ?(protocol_data : block_header_data option) + () = + let level = Int32.succ pred_level in + let fitness = pred_fitness in + Alpha_context.prepare ~timestamp ~level ~fitness ctxt >>=? fun ctxt -> + begin + match protocol_data with + | None -> + Apply.begin_partial_construction ctxt >>=? fun ctxt -> + let mode = Partial_construction { predecessor } in + return (mode, ctxt) + | Some proto_header -> + Apply.begin_full_construction + ctxt pred_timestamp + proto_header.contents >>=? fun (ctxt, protocol_data, baker) -> + let mode = + let baker = Signature.Public_key.hash baker in + Full_construction { predecessor ; baker ; protocol_data } in + return (mode, ctxt) + end >>=? fun (mode, ctxt) -> + return { mode ; chain_id ; ctxt ; op_count = 0 } + +let apply_operation + ({ mode ; chain_id ; ctxt ; op_count ; _ } as data) + (operation : Alpha_context.packed_operation) = + match mode with + | Partial_application _ when + not (List.exists + (Compare.Int.equal 0) + (Alpha_context.Operation.acceptable_passes operation)) -> + (* Multipass validation only considers operations in pass 0. *) + let op_count = op_count + 1 in + return ({ data with ctxt ; op_count }, No_operation_metadata) + | _ -> + let { shell ; protocol_data = Operation_data protocol_data } = operation in + let operation : _ Alpha_context.operation = { shell ; protocol_data } in + let predecessor, baker = + match mode with + | Partial_application + { block_header = { shell = { predecessor ; _ } ; _ } ; baker } + | Application + { block_header = { shell = { predecessor ; _ } ; _ } ; baker } + | Full_construction { predecessor ; baker ; _ } + -> predecessor, baker + | Partial_construction { predecessor } + -> predecessor, Signature.Public_key_hash.zero + in + let partial = + match mode with + | Partial_construction _ -> true + | Application _ + | Full_construction _ + | Partial_application _ -> false in + Apply.apply_operation ~partial ctxt chain_id Optimized predecessor baker + (Alpha_context.Operation.hash operation) + operation >>=? fun (ctxt, result) -> + let op_count = op_count + 1 in + return ({ data with ctxt ; op_count }, Operation_metadata result) + +let finalize_block { mode ; ctxt ; op_count } = + match mode with + | Partial_construction _ -> + let level = Alpha_context.Level.current ctxt in + Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> + let baker = Signature.Public_key_hash.zero in + Signature.Public_key_hash.Map.fold + (fun delegate deposit ctxt -> + ctxt >>=? fun ctxt -> + Alpha_context.Delegate.freeze_deposit ctxt delegate deposit) + (Alpha_context.get_deposits ctxt) + (return ctxt) >>=? fun ctxt -> + let ctxt = Alpha_context.finalize ctxt in + return (ctxt, Apply_results.{ baker ; + level ; + voting_period_kind ; + nonce_hash = None ; + consumed_gas = Z.zero ; + deactivated = []; + balance_updates = []}) + | Partial_application { baker ; _ } -> + let level = Alpha_context. Level.current ctxt in + Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> + let ctxt = Alpha_context.finalize ctxt in + return (ctxt, Apply_results.{ baker ; + level ; + voting_period_kind ; + nonce_hash = None ; + consumed_gas = Z.zero ; + deactivated = []; + balance_updates = []}) + | Application + { baker ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } } + | Full_construction { protocol_data ; baker ; _ } -> + Apply.finalize_application ctxt protocol_data baker >>=? fun (ctxt, receipt) -> + let level = Alpha_context.Level.current ctxt in + let priority = protocol_data.priority in + let raw_level = Alpha_context.Raw_level.to_int32 level.level in + let fitness = Alpha_context.Fitness.current ctxt in + let commit_message = + Format.asprintf + "lvl %ld, fit %Ld, prio %d, %d ops" + raw_level fitness priority op_count in + let ctxt = Alpha_context.finalize ~commit_message ctxt in + return (ctxt, receipt) + +let compare_operations op1 op2 = + let open Alpha_context in + let Operation_data op1 = op1.protocol_data in + let Operation_data op2 = op2.protocol_data in + match op1.contents, op2.contents with + | Single (Endorsement _), Single (Endorsement _) -> 0 + | _, Single (Endorsement _) -> 1 + | Single (Endorsement _), _ -> -1 + + | Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _) -> 0 + | _, Single (Seed_nonce_revelation _) -> 1 + | Single (Seed_nonce_revelation _), _ -> -1 + + | Single (Double_endorsement_evidence _), Single (Double_endorsement_evidence _) -> 0 + | _, Single (Double_endorsement_evidence _) -> 1 + | Single (Double_endorsement_evidence _), _ -> -1 + + | Single (Double_baking_evidence _), Single (Double_baking_evidence _) -> 0 + | _, Single (Double_baking_evidence _) -> 1 + | Single (Double_baking_evidence _), _ -> -1 + + | Single (Activate_account _), Single (Activate_account _) -> 0 + | _, Single (Activate_account _) -> 1 + | Single (Activate_account _), _ -> -1 + + | Single (Proposals _), Single (Proposals _) -> 0 + | _, Single (Proposals _) -> 1 + | Single (Proposals _), _ -> -1 + + | Single (Ballot _), Single (Ballot _) -> 0 + | _, Single (Ballot _) -> 1 + | Single (Ballot _), _ -> -1 + + (* Manager operations with smaller counter are pre-validated first. *) + | Single (Manager_operation op1), Single (Manager_operation op2) -> + Z.compare op1.counter op2.counter + | Cons (Manager_operation op1, _), Single (Manager_operation op2) -> + Z.compare op1.counter op2.counter + | Single (Manager_operation op1), Cons (Manager_operation op2, _) -> + Z.compare op1.counter op2.counter + | Cons (Manager_operation op1, _), Cons (Manager_operation op2, _) -> + Z.compare op1.counter op2.counter + +let init ctxt block_header = + let level = block_header.Block_header.level in + let fitness = block_header.fitness in + let timestamp = block_header.timestamp in + let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) = + Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) -> + Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) -> + return ((script, big_map_diff), ctxt) + in + Alpha_context.prepare_first_block + ~typecheck + ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + return (Alpha_context.finalize ctxt) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/main.mli b/vendors/ligo-utils/tezos-protocol-alpha/main.mli new file mode 100644 index 000000000..bde08a85e --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/main.mli @@ -0,0 +1,67 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Protocol Signature Instance *) + +type validation_mode = + | Application of { + block_header : Alpha_context.Block_header.t ; + baker : Alpha_context.public_key_hash ; + } + | Partial_application of { + block_header : Alpha_context.Block_header.t ; + baker : Alpha_context.public_key_hash ; + } + | Partial_construction of { + predecessor : Block_hash.t ; + } + | Full_construction of { + predecessor : Block_hash.t ; + protocol_data : Alpha_context.Block_header.contents ; + baker : Alpha_context.public_key_hash ; + } + +type validation_state = + { mode : validation_mode ; + chain_id : Chain_id.t ; + ctxt : Alpha_context.t ; + op_count : int ; + } + +type operation_data = Alpha_context.packed_protocol_data + +type operation = Alpha_context.packed_operation = { + shell: Operation.shell_header ; + protocol_data: operation_data ; +} + +include Updater.PROTOCOL + with type block_header_data = Alpha_context.Block_header.protocol_data + and type block_header_metadata = Apply_results.block_metadata + and type block_header = Alpha_context.Block_header.t + and type operation_data := operation_data + and type operation_receipt = Apply_results.packed_operation_metadata + and type operation := operation + and type validation_state := validation_state diff --git a/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml new file mode 100644 index 000000000..8b7561aeb --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml @@ -0,0 +1,60 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *) + +type manager_key = + | Hash of Signature.Public_key_hash.t + | Public_key of Signature.Public_key.t + +type t = manager_key + +open Data_encoding + +let hash_case tag = + case tag + ~title:"Public_key_hash" + Signature.Public_key_hash.encoding + (function + | Hash hash -> Some hash + | _ -> None) + (fun hash -> Hash hash) + +let pubkey_case tag = + case tag + ~title:"Public_key" + Signature.Public_key.encoding + (function + | Public_key hash -> Some hash + | _ -> None) + (fun hash -> Public_key hash) + + +let encoding = + union [ + hash_case (Tag 0) ; + pubkey_case (Tag 1) ; + ] + diff --git a/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.mli new file mode 100644 index 000000000..d8970081a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.mli @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *) + +(** The public key of the manager of a contract is reveled only after the + first operation. At Origination time, the manager provides only the hash + of its public key that is stored in the contract. When the public key + is actually reveeld, the public key instead of the hash of the key *) +type manager_key = + | Hash of Signature.Public_key_hash.t + | Public_key of Signature.Public_key.t + +type t = manager_key + +val encoding : t Data_encoding.encoding diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml new file mode 100644 index 000000000..0e7e45617 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml @@ -0,0 +1,436 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Gas + +module Cost_of = struct + let cycle = step_cost 1 + let nop = free + + let stack_op = step_cost 1 + + let bool_binop _ _ = step_cost 1 + let bool_unop _ = step_cost 1 + + let pair = alloc_cost 2 + let pair_access = step_cost 1 + + let cons = alloc_cost 2 + + let variant_no_data = alloc_cost 1 + + let branch = step_cost 2 + + let string length = + alloc_bytes_cost length + + let bytes length = + alloc_mbytes_cost length + + let zint z = + alloc_bits_cost (Z.numbits z) + + let concat cost length ss = + let rec cum acc = function + | [] -> acc + | s :: ss -> cum (cost (length s) +@ acc) ss in + cum free ss + + let concat_string ss = concat string String.length ss + let concat_bytes ss = concat bytes MBytes.length ss + + let slice_string length = string length + let slice_bytes = alloc_cost 0 + + (* Cost per cycle of a loop, fold, etc *) + let loop_cycle = step_cost 2 + + let list_size = step_cost 1 + + let log2 = + let rec help acc = function + | 0 -> acc + | n -> help (acc + 1) (n / 2) + in help 1 + + let module_cost = alloc_cost 10 + + let map_access : type key value. (key, value) Script_typed_ir.map -> int + = fun (module Box) -> + log2 (snd Box.boxed) + + let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost + = fun (module Box) -> + let size = snd Box.boxed in + 3 *@ alloc_cost size + + let map_mem _key map = step_cost (map_access map) + + let map_get = map_mem + + let map_update _ _ map = + map_access map *@ alloc_cost 3 + + let map_size = step_cost 2 + + let big_map_mem _key _map = step_cost 50 + let big_map_get _key _map = step_cost 50 + let big_map_update _key _value _map = step_cost 10 + + let set_access : type elt. elt -> elt Script_typed_ir.set -> int + = fun _key (module Box) -> + log2 @@ Box.size + + let set_mem key set = step_cost (set_access key set) + + let set_update key _presence set = + set_access key set *@ alloc_cost 3 + + (* for LEFT, RIGHT, SOME *) + let wrap = alloc_cost 1 + + let mul n1 n2 = + let steps = + (Z.numbits (Script_int.to_zint n1)) + * (Z.numbits (Script_int.to_zint n2)) in + let bits = + (Z.numbits (Script_int.to_zint n1)) + + (Z.numbits (Script_int.to_zint n2)) in + step_cost steps +@ alloc_bits_cost bits + + let div n1 n2 = + mul n1 n2 +@ alloc_cost 2 + + let add_sub_z n1 n2 = + let bits = + Compare.Int.max (Z.numbits n1) (Z.numbits n2) in + step_cost bits +@ alloc_cost bits + + let add n1 n2 = + add_sub_z (Script_int.to_zint n1) (Script_int.to_zint n2) + + let sub = add + + let abs n = + alloc_bits_cost (Z.numbits @@ Script_int.to_zint n) + + let neg = abs + let int _ = step_cost 1 + + let add_timestamp t n = + add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n) + + let sub_timestamp t n = + add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n) + + let diff_timestamps t1 t2 = + add_sub_z (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2) + + let empty_set = module_cost + + let set_size = step_cost 2 + + let set_to_list : type item. item Script_typed_ir.set -> cost + = fun (module Box) -> + alloc_cost @@ Pervasives.(Box.size * 2) + + let empty_map = module_cost + + let int64_op = step_cost 1 +@ alloc_cost 1 + + let z_to_int64 = step_cost 2 +@ alloc_cost 1 + + let int64_to_z = step_cost 2 +@ alloc_cost 1 + + let bitwise_binop n1 n2 = + let bits = Compare.Int.max (Z.numbits (Script_int.to_zint n1)) (Z.numbits (Script_int.to_zint n2)) in + step_cost bits +@ alloc_bits_cost bits + + let logor = bitwise_binop + let logand = bitwise_binop + let logxor = bitwise_binop + let lognot n = + let bits = Z.numbits @@ Script_int.to_zint n in + step_cost bits +@ alloc_cost bits + + let unopt ~default = function + | None -> default + | Some x -> x + + let max_int = 1073741823 + + let shift_left x y = + alloc_bits_cost + (Z.numbits (Script_int.to_zint x) + + (unopt (Script_int.to_int y) ~default:max_int)) + + let shift_right x y = + alloc_bits_cost + (Compare.Int.max 1 + (Z.numbits (Script_int.to_zint x) - + unopt (Script_int.to_int y) ~default:max_int)) + + let exec = step_cost 1 + + let push = step_cost 1 + + let compare_res = step_cost 1 + + let unpack_failed bytes = + (* We cannot instrument failed deserialization, + so we take worst case fees: a set of size 1 bytes values. *) + let len = MBytes.length bytes in + (len *@ alloc_mbytes_cost 1) +@ + (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) + + let address = step_cost 1 + let contract = Gas.read_bytes_cost Z.zero +@ step_cost 10000 + let transfer = step_cost 10 + let create_account = step_cost 10 + let create_contract = step_cost 10 + let implicit_account = step_cost 10 + let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32) + let balance = step_cost 1 +@ read_bytes_cost (Z.of_int 8) + let now = step_cost 5 + let check_signature = step_cost 1000 + let hash_key = step_cost 3 +@ bytes 20 + let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len + let steps_to_quota = step_cost 1 + let source = step_cost 1 + let self = step_cost 1 + let amount = step_cost 1 + let compare_bool _ _ = step_cost 1 + let compare_string s1 s2 = + step_cost ((7 + Compare.Int.max (String.length s1) (String.length s2)) / 8) +@ step_cost 1 + let compare_bytes s1 s2 = + step_cost ((7 + Compare.Int.max (MBytes.length s1) (MBytes.length s2)) / 8) +@ step_cost 1 + let compare_tez _ _ = step_cost 1 + let compare_zint n1 n2 = step_cost ((7 + Compare.Int.max (Z.numbits n1) (Z.numbits n2)) / 8) +@ step_cost 1 + let compare_int n1 n2 = compare_zint (Script_int.to_zint n1) (Script_int.to_zint n2) + let compare_nat = compare_int + let compare_key_hash _ _ = alloc_bytes_cost 36 + let compare_timestamp t1 t2 = compare_zint (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2) + let compare_address _ _ = step_cost 20 + + let manager_operation = step_cost 10_000 + + module Typechecking = struct + let cycle = step_cost 1 + let bool = free + let unit = free + let string = string + let bytes = bytes + let z = zint + let int_of_string str = + alloc_cost @@ (Pervasives.(/) (String.length str) 5) + let tez = step_cost 1 +@ alloc_cost 1 + let string_timestamp = step_cost 3 +@ alloc_cost 3 + let key = step_cost 3 +@ alloc_cost 3 + let key_hash = step_cost 1 +@ alloc_cost 1 + let signature = step_cost 1 +@ alloc_cost 1 + let contract = step_cost 5 + let get_script = step_cost 20 +@ alloc_cost 5 + let contract_exists = step_cost 15 +@ alloc_cost 5 + let pair = alloc_cost 2 + let union = alloc_cost 1 + let lambda = alloc_cost 5 +@ step_cost 3 + let some = alloc_cost 1 + let none = alloc_cost 0 + let list_element = alloc_cost 2 +@ step_cost 1 + let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2) + let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2) + let primitive_type = alloc_cost 1 + let one_arg_type = alloc_cost 2 + let two_arg_type = alloc_cost 3 + let operation b = bytes b + let type_ nb_args = alloc_cost (nb_args + 1) + + (* Cost of parsing instruction, is cost of allocation of + constructor + cost of contructor parameters + cost of + allocation on the stack type *) + let instr + : type b a. (b, a) Script_typed_ir.instr -> cost + = fun i -> + let open Script_typed_ir in + alloc_cost 1 +@ (* cost of allocation of constructor *) + match i with + | Drop -> alloc_cost 0 + | Dup -> alloc_cost 1 + | Swap -> alloc_cost 0 + | Const _ -> alloc_cost 1 + | Cons_pair -> alloc_cost 2 + | Car -> alloc_cost 1 + | Cdr -> alloc_cost 1 + | Cons_some -> alloc_cost 2 + | Cons_none _ -> alloc_cost 3 + | If_none _ -> alloc_cost 2 + | Left -> alloc_cost 3 + | Right -> alloc_cost 3 + | If_left _ -> alloc_cost 2 + | Cons_list -> alloc_cost 1 + | Nil -> alloc_cost 1 + | If_cons _ -> alloc_cost 2 + | List_map _ -> alloc_cost 5 + | List_iter _ -> alloc_cost 4 + | List_size -> alloc_cost 1 + | Empty_set _ -> alloc_cost 1 + | Set_iter _ -> alloc_cost 4 + | Set_mem -> alloc_cost 1 + | Set_update -> alloc_cost 1 + | Set_size -> alloc_cost 1 + | Empty_map _ -> alloc_cost 2 + | Map_map _ -> alloc_cost 5 + | Map_iter _ -> alloc_cost 4 + | Map_mem -> alloc_cost 1 + | Map_get -> alloc_cost 1 + | Map_update -> alloc_cost 1 + | Map_size -> alloc_cost 1 + | Big_map_mem -> alloc_cost 1 + | Big_map_get -> alloc_cost 1 + | Big_map_update -> alloc_cost 1 + | Concat_string -> alloc_cost 1 + | Concat_string_pair -> alloc_cost 1 + | Concat_bytes -> alloc_cost 1 + | Concat_bytes_pair -> alloc_cost 1 + | Slice_string -> alloc_cost 1 + | Slice_bytes -> alloc_cost 1 + | String_size -> alloc_cost 1 + | Bytes_size -> alloc_cost 1 + | Add_seconds_to_timestamp -> alloc_cost 1 + | Add_timestamp_to_seconds -> alloc_cost 1 + | Sub_timestamp_seconds -> alloc_cost 1 + | Diff_timestamps -> alloc_cost 1 + | Add_tez -> alloc_cost 1 + | Sub_tez -> alloc_cost 1 + | Mul_teznat -> alloc_cost 1 + | Mul_nattez -> alloc_cost 1 + | Ediv_teznat -> alloc_cost 1 + | Ediv_tez -> alloc_cost 1 + | Or -> alloc_cost 1 + | And -> alloc_cost 1 + | Xor -> alloc_cost 1 + | Not -> alloc_cost 1 + | Is_nat -> alloc_cost 1 + | Neg_nat -> alloc_cost 1 + | Neg_int -> alloc_cost 1 + | Abs_int -> alloc_cost 1 + | Int_nat -> alloc_cost 1 + | Add_intint -> alloc_cost 1 + | Add_intnat -> alloc_cost 1 + | Add_natint -> alloc_cost 1 + | Add_natnat -> alloc_cost 1 + | Sub_int -> alloc_cost 1 + | Mul_intint -> alloc_cost 1 + | Mul_intnat -> alloc_cost 1 + | Mul_natint -> alloc_cost 1 + | Mul_natnat -> alloc_cost 1 + | Ediv_intint -> alloc_cost 1 + | Ediv_intnat -> alloc_cost 1 + | Ediv_natint -> alloc_cost 1 + | Ediv_natnat -> alloc_cost 1 + | Lsl_nat -> alloc_cost 1 + | Lsr_nat -> alloc_cost 1 + | Or_nat -> alloc_cost 1 + | And_nat -> alloc_cost 1 + | And_int_nat -> alloc_cost 1 + | Xor_nat -> alloc_cost 1 + | Not_nat -> alloc_cost 1 + | Not_int -> alloc_cost 1 + | Seq _ -> alloc_cost 8 + | If _ -> alloc_cost 8 + | Loop _ -> alloc_cost 4 + | Loop_left _ -> alloc_cost 5 + | Dip _ -> alloc_cost 4 + | Exec -> alloc_cost 1 + | Lambda _ -> alloc_cost 2 + | Failwith _ -> alloc_cost 1 + | Nop -> alloc_cost 0 + | Compare _ -> alloc_cost 1 + | Eq -> alloc_cost 1 + | Neq -> alloc_cost 1 + | Lt -> alloc_cost 1 + | Gt -> alloc_cost 1 + | Le -> alloc_cost 1 + | Ge -> alloc_cost 1 + | Address -> alloc_cost 1 + | Contract _ -> alloc_cost 2 + | Transfer_tokens -> alloc_cost 1 + | Create_account -> alloc_cost 2 + | Implicit_account -> alloc_cost 1 + | Create_contract _ -> alloc_cost 8 + | Set_delegate -> alloc_cost 1 + | Now -> alloc_cost 1 + | Balance -> alloc_cost 1 + | Check_signature -> alloc_cost 1 + | Hash_key -> alloc_cost 1 + | Pack _ -> alloc_cost 2 + | Unpack _ -> alloc_cost 2 + | Blake2b -> alloc_cost 1 + | Sha256 -> alloc_cost 1 + | Sha512 -> alloc_cost 1 + | Steps_to_quota -> alloc_cost 1 + | Source -> alloc_cost 1 + | Sender -> alloc_cost 1 + | Self _ -> alloc_cost 2 + | Amount -> alloc_cost 1 + end + + module Unparse = struct + let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot + let seq_cost = Script.seq_node_cost_nonrec_of_length + let string_cost length = Script.string_node_cost_of_length length + + let cycle = step_cost 1 + let bool = prim_cost 0 [] + let unit = prim_cost 0 [] + (* We count the length of strings and bytes to prevent hidden + miscalculations due to non detectable expansion of sharing. *) + let string s = Script.string_node_cost s + let bytes s = Script.bytes_node_cost s + let z i = Script.int_node_cost i + let int i = Script.int_node_cost (Script_int.to_zint i) + let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *) + let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int + let operation bytes = Script.bytes_node_cost bytes + let key = string_cost 54 + let key_hash = string_cost 36 + let signature = string_cost 128 + let contract = string_cost 36 + let pair = prim_cost 2 [] + let union = prim_cost 1 [] + let some = prim_cost 1 [] + let none = prim_cost 0 [] + let list_element = alloc_cost 2 + let set_element = alloc_cost 2 + let map_element = alloc_cost 2 + let one_arg_type = prim_cost 1 + let two_arg_type = prim_cost 2 + + let set_to_list = set_to_list + let map_to_list = map_to_list + end + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli new file mode 100644 index 000000000..cfb121cf9 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli @@ -0,0 +1,200 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +module Cost_of : sig + val cycle : Gas.cost + val loop_cycle : Gas.cost + val list_size : Gas.cost + val nop : Gas.cost + val stack_op : Gas.cost + val bool_binop : 'a -> 'b -> Gas.cost + val bool_unop : 'a -> Gas.cost + val pair : Gas.cost + val pair_access : Gas.cost + val cons : Gas.cost + val variant_no_data : Gas.cost + val branch : Gas.cost + val concat_string : string list -> Gas.cost + val concat_bytes : MBytes.t list -> Gas.cost + val slice_string : int -> Gas.cost + val slice_bytes : Gas.cost + val map_mem : + 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost + val map_to_list : + ('b, 'c) Script_typed_ir.map -> Gas.cost + val map_get : + 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost + val map_update : + 'a -> 'b -> ('c, 'd) Script_typed_ir.map -> Gas.cost + val map_size : Gas.cost + val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost + val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost + val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost + val set_to_list : 'a Script_typed_ir.set -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost + val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost + val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val abs : 'a Script_int.num -> Gas.cost + val neg : 'a Script_int.num -> Gas.cost + val int : 'a -> Gas.cost + val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost + val empty_set : Gas.cost + val set_size : Gas.cost + val empty_map : Gas.cost + val int64_op : Gas.cost + val z_to_int64 : Gas.cost + val int64_to_z : Gas.cost + val bitwise_binop : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val lognot : 'a Script_int.num -> Gas.cost + val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val exec : Gas.cost + val push : Gas.cost + val compare_res : Gas.cost + val unpack_failed : MBytes.t -> Gas.cost + val address : Gas.cost + val contract : Gas.cost + val transfer : Gas.cost + val create_account : Gas.cost + val create_contract : Gas.cost + val implicit_account : Gas.cost + val set_delegate : Gas.cost + val balance : Gas.cost + val now : Gas.cost + val check_signature : Gas.cost + val hash_key : Gas.cost + val hash : MBytes.t -> int -> Gas.cost + val steps_to_quota : Gas.cost + val source : Gas.cost + val self : Gas.cost + val amount : Gas.cost + val wrap : Gas.cost + val compare_bool : 'a -> 'b -> Gas.cost + val compare_string : string -> string -> Gas.cost + val compare_bytes : MBytes.t -> MBytes.t -> Gas.cost + val compare_tez : 'a -> 'b -> Gas.cost + val compare_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val compare_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val compare_key_hash : 'a -> 'b -> Gas.cost + val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> Gas.cost + val compare_address : Contract.t -> Contract.t -> Gas.cost + + val manager_operation : Gas.cost + + module Typechecking : sig + val cycle : Gas.cost + val unit : Gas.cost + val bool : Gas.cost + val tez : Gas.cost + val z : Z.t -> Gas.cost + val string : int -> Gas.cost + val bytes : int -> Gas.cost + val int_of_string : string -> Gas.cost + val string_timestamp : Gas.cost + val key : Gas.cost + val key_hash : Gas.cost + val signature : Gas.cost + + val contract : Gas.cost + + (** Gas.Cost of getting the code for a contract *) + val get_script : Gas.cost + + val contract_exists : Gas.cost + + (** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type *) + val pair : Gas.cost + + val union : Gas.cost + + val lambda : Gas.cost + + val some : Gas.cost + val none : Gas.cost + + val list_element : Gas.cost + val set_element : int -> Gas.cost + val map_element : int -> Gas.cost + + val primitive_type : Gas.cost + val one_arg_type : Gas.cost + val two_arg_type : Gas.cost + + val operation : int -> Gas.cost + + (** Cost of parsing a type *) + val type_ : int -> Gas.cost + + (** Cost of parsing an instruction *) + val instr : ('a, 'b) Script_typed_ir.instr -> Gas.cost + end + + module Unparse : sig + val prim_cost : int -> Script.annot -> Gas.cost + val seq_cost : int -> Gas.cost + val cycle : Gas.cost + val unit : Gas.cost + val bool : Gas.cost + val z : Z.t -> Gas.cost + val int : 'a Script_int.num -> Gas.cost + val tez : Gas.cost + val string : string -> Gas.cost + val bytes : MBytes.t -> Gas.cost + val timestamp : Script_timestamp.t -> Gas.cost + val key : Gas.cost + val key_hash : Gas.cost + val signature : Gas.cost + val operation : MBytes.t -> Gas.cost + + val contract : Gas.cost + + (** Additional Gas.cost of parsing a pair over the Gas.cost of parsing each type *) + val pair : Gas.cost + + val union : Gas.cost + + val some : Gas.cost + val none : Gas.cost + + val list_element : Gas.cost + val set_element : Gas.cost + val map_element : Gas.cost + + val one_arg_type : Script.annot -> Gas.cost + val two_arg_type : Script.annot -> Gas.cost + val set_to_list : 'a Script_typed_ir.set -> Gas.cost + val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost + end +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml new file mode 100644 index 000000000..d80f5f7eb --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml @@ -0,0 +1,597 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Micheline + +type error += Unknown_primitive_name of string +type error += Invalid_case of string +type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location + +type prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + +let valid_case name = + let is_lower = function '_' | 'a'..'z' -> true | _ -> false in + let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in + let rec for_all a b f = + Compare.Int.(a > b) || f a && for_all (a + 1) b f in + let len = String.length name in + Compare.Int.(len <> 0) + && + Compare.Char.(String.get name 0 <> '_') + && + ((is_upper (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_upper (String.get name i))) + || + (is_upper (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_lower (String.get name i))) + || + (is_lower (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))) + +let string_of_prim = function + | K_parameter -> "parameter" + | K_storage -> "storage" + | K_code -> "code" + | D_False -> "False" + | D_Elt -> "Elt" + | D_Left -> "Left" + | D_None -> "None" + | D_Pair -> "Pair" + | D_Right -> "Right" + | D_Some -> "Some" + | D_True -> "True" + | D_Unit -> "Unit" + | I_PACK -> "PACK" + | I_UNPACK -> "UNPACK" + | I_BLAKE2B -> "BLAKE2B" + | I_SHA256 -> "SHA256" + | I_SHA512 -> "SHA512" + | I_ABS -> "ABS" + | I_ADD -> "ADD" + | I_AMOUNT -> "AMOUNT" + | I_AND -> "AND" + | I_BALANCE -> "BALANCE" + | I_CAR -> "CAR" + | I_CDR -> "CDR" + | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" + | I_COMPARE -> "COMPARE" + | I_CONCAT -> "CONCAT" + | I_CONS -> "CONS" + | I_CREATE_ACCOUNT -> "CREATE_ACCOUNT" + | I_CREATE_CONTRACT -> "CREATE_CONTRACT" + | I_IMPLICIT_ACCOUNT -> "IMPLICIT_ACCOUNT" + | I_DIP -> "DIP" + | I_DROP -> "DROP" + | I_DUP -> "DUP" + | I_EDIV -> "EDIV" + | I_EMPTY_MAP -> "EMPTY_MAP" + | I_EMPTY_SET -> "EMPTY_SET" + | I_EQ -> "EQ" + | I_EXEC -> "EXEC" + | I_FAILWITH -> "FAILWITH" + | I_GE -> "GE" + | I_GET -> "GET" + | I_GT -> "GT" + | I_HASH_KEY -> "HASH_KEY" + | I_IF -> "IF" + | I_IF_CONS -> "IF_CONS" + | I_IF_LEFT -> "IF_LEFT" + | I_IF_NONE -> "IF_NONE" + | I_INT -> "INT" + | I_LAMBDA -> "LAMBDA" + | I_LE -> "LE" + | I_LEFT -> "LEFT" + | I_LOOP -> "LOOP" + | I_LSL -> "LSL" + | I_LSR -> "LSR" + | I_LT -> "LT" + | I_MAP -> "MAP" + | I_MEM -> "MEM" + | I_MUL -> "MUL" + | I_NEG -> "NEG" + | I_NEQ -> "NEQ" + | I_NIL -> "NIL" + | I_NONE -> "NONE" + | I_NOT -> "NOT" + | I_NOW -> "NOW" + | I_OR -> "OR" + | I_PAIR -> "PAIR" + | I_PUSH -> "PUSH" + | I_RIGHT -> "RIGHT" + | I_SIZE -> "SIZE" + | I_SOME -> "SOME" + | I_SOURCE -> "SOURCE" + | I_SENDER -> "SENDER" + | I_SELF -> "SELF" + | I_SLICE -> "SLICE" + | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" + | I_SUB -> "SUB" + | I_SWAP -> "SWAP" + | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS" + | I_SET_DELEGATE -> "SET_DELEGATE" + | I_UNIT -> "UNIT" + | I_UPDATE -> "UPDATE" + | I_XOR -> "XOR" + | I_ITER -> "ITER" + | I_LOOP_LEFT -> "LOOP_LEFT" + | I_ADDRESS -> "ADDRESS" + | I_CONTRACT -> "CONTRACT" + | I_ISNAT -> "ISNAT" + | I_CAST -> "CAST" + | I_RENAME -> "RENAME" + | T_bool -> "bool" + | T_contract -> "contract" + | T_int -> "int" + | T_key -> "key" + | T_key_hash -> "key_hash" + | T_lambda -> "lambda" + | T_list -> "list" + | T_map -> "map" + | T_big_map -> "big_map" + | T_nat -> "nat" + | T_option -> "option" + | T_or -> "or" + | T_pair -> "pair" + | T_set -> "set" + | T_signature -> "signature" + | T_string -> "string" + | T_bytes -> "bytes" + | T_mutez -> "mutez" + | T_timestamp -> "timestamp" + | T_unit -> "unit" + | T_operation -> "operation" + | T_address -> "address" + +let prim_of_string = function + | "parameter" -> ok K_parameter + | "storage" -> ok K_storage + | "code" -> ok K_code + | "False" -> ok D_False + | "Elt" -> ok D_Elt + | "Left" -> ok D_Left + | "None" -> ok D_None + | "Pair" -> ok D_Pair + | "Right" -> ok D_Right + | "Some" -> ok D_Some + | "True" -> ok D_True + | "Unit" -> ok D_Unit + | "PACK" -> ok I_PACK + | "UNPACK" -> ok I_UNPACK + | "BLAKE2B" -> ok I_BLAKE2B + | "SHA256" -> ok I_SHA256 + | "SHA512" -> ok I_SHA512 + | "ABS" -> ok I_ABS + | "ADD" -> ok I_ADD + | "AMOUNT" -> ok I_AMOUNT + | "AND" -> ok I_AND + | "BALANCE" -> ok I_BALANCE + | "CAR" -> ok I_CAR + | "CDR" -> ok I_CDR + | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE + | "COMPARE" -> ok I_COMPARE + | "CONCAT" -> ok I_CONCAT + | "CONS" -> ok I_CONS + | "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT + | "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT + | "IMPLICIT_ACCOUNT" -> ok I_IMPLICIT_ACCOUNT + | "DIP" -> ok I_DIP + | "DROP" -> ok I_DROP + | "DUP" -> ok I_DUP + | "EDIV" -> ok I_EDIV + | "EMPTY_MAP" -> ok I_EMPTY_MAP + | "EMPTY_SET" -> ok I_EMPTY_SET + | "EQ" -> ok I_EQ + | "EXEC" -> ok I_EXEC + | "FAILWITH" -> ok I_FAILWITH + | "GE" -> ok I_GE + | "GET" -> ok I_GET + | "GT" -> ok I_GT + | "HASH_KEY" -> ok I_HASH_KEY + | "IF" -> ok I_IF + | "IF_CONS" -> ok I_IF_CONS + | "IF_LEFT" -> ok I_IF_LEFT + | "IF_NONE" -> ok I_IF_NONE + | "INT" -> ok I_INT + | "LAMBDA" -> ok I_LAMBDA + | "LE" -> ok I_LE + | "LEFT" -> ok I_LEFT + | "LOOP" -> ok I_LOOP + | "LSL" -> ok I_LSL + | "LSR" -> ok I_LSR + | "LT" -> ok I_LT + | "MAP" -> ok I_MAP + | "MEM" -> ok I_MEM + | "MUL" -> ok I_MUL + | "NEG" -> ok I_NEG + | "NEQ" -> ok I_NEQ + | "NIL" -> ok I_NIL + | "NONE" -> ok I_NONE + | "NOT" -> ok I_NOT + | "NOW" -> ok I_NOW + | "OR" -> ok I_OR + | "PAIR" -> ok I_PAIR + | "PUSH" -> ok I_PUSH + | "RIGHT" -> ok I_RIGHT + | "SIZE" -> ok I_SIZE + | "SOME" -> ok I_SOME + | "SOURCE" -> ok I_SOURCE + | "SENDER" -> ok I_SENDER + | "SELF" -> ok I_SELF + | "SLICE" -> ok I_SLICE + | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA + | "SUB" -> ok I_SUB + | "SWAP" -> ok I_SWAP + | "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS + | "SET_DELEGATE" -> ok I_SET_DELEGATE + | "UNIT" -> ok I_UNIT + | "UPDATE" -> ok I_UPDATE + | "XOR" -> ok I_XOR + | "ITER" -> ok I_ITER + | "LOOP_LEFT" -> ok I_LOOP_LEFT + | "ADDRESS" -> ok I_ADDRESS + | "CONTRACT" -> ok I_CONTRACT + | "ISNAT" -> ok I_ISNAT + | "CAST" -> ok I_CAST + | "RENAME" -> ok I_RENAME + | "bool" -> ok T_bool + | "contract" -> ok T_contract + | "int" -> ok T_int + | "key" -> ok T_key + | "key_hash" -> ok T_key_hash + | "lambda" -> ok T_lambda + | "list" -> ok T_list + | "map" -> ok T_map + | "big_map" -> ok T_big_map + | "nat" -> ok T_nat + | "option" -> ok T_option + | "or" -> ok T_or + | "pair" -> ok T_pair + | "set" -> ok T_set + | "signature" -> ok T_signature + | "string" -> ok T_string + | "bytes" -> ok T_bytes + | "mutez" -> ok T_mutez + | "timestamp" -> ok T_timestamp + | "unit" -> ok T_unit + | "operation" -> ok T_operation + | "address" -> ok T_address + | n -> + if valid_case n then + error (Unknown_primitive_name n) + else + error (Invalid_case n) + +let prims_of_strings expr = + let rec convert = function + | Int _ | String _ | Bytes _ as expr -> ok expr + | Prim (loc, prim, args, annot) -> + Error_monad.record_trace + (Invalid_primitive_name (expr, loc)) + (prim_of_string prim) >>? fun prim -> + List.fold_left + (fun acc arg -> + acc >>? fun args -> + convert arg >>? fun arg -> + ok (arg :: args)) + (ok []) args >>? fun args -> + ok (Prim (0, prim, List.rev args, annot)) + | Seq (_, args) -> + List.fold_left + (fun acc arg -> + acc >>? fun args -> + convert arg >>? fun arg -> + ok (arg :: args)) + (ok []) args >>? fun args -> + ok (Seq (0, List.rev args)) in + convert (root expr) >>? fun expr -> + ok (strip_locations expr) + +let strings_of_prims expr = + let rec convert = function + | Int _ | String _ | Bytes _ as expr -> expr + | Prim (_, prim, args, annot) -> + let prim = string_of_prim prim in + let args = List.map convert args in + Prim (0, prim, args, annot) + | Seq (_, args) -> + let args = List.map convert args in + Seq (0, args) in + strip_locations (convert (root expr)) + +let prim_encoding = + let open Data_encoding in + def "michelson.v1.primitives" @@ + string_enum [ + ("parameter", K_parameter) ; + ("storage", K_storage) ; + ("code", K_code) ; + ("False", D_False) ; + ("Elt", D_Elt) ; + ("Left", D_Left) ; + ("None", D_None) ; + ("Pair", D_Pair) ; + ("Right", D_Right) ; + ("Some", D_Some) ; + ("True", D_True) ; + ("Unit", D_Unit) ; + ("PACK", I_PACK) ; + ("UNPACK", I_UNPACK) ; + ("BLAKE2B", I_BLAKE2B) ; + ("SHA256", I_SHA256) ; + ("SHA512", I_SHA512) ; + ("ABS", I_ABS) ; + ("ADD", I_ADD) ; + ("AMOUNT", I_AMOUNT) ; + ("AND", I_AND) ; + ("BALANCE", I_BALANCE) ; + ("CAR", I_CAR) ; + ("CDR", I_CDR) ; + ("CHECK_SIGNATURE", I_CHECK_SIGNATURE) ; + ("COMPARE", I_COMPARE) ; + ("CONCAT", I_CONCAT) ; + ("CONS", I_CONS) ; + ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ; + ("CREATE_CONTRACT", I_CREATE_CONTRACT) ; + ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ; + ("DIP", I_DIP) ; + ("DROP", I_DROP) ; + ("DUP", I_DUP) ; + ("EDIV", I_EDIV) ; + ("EMPTY_MAP", I_EMPTY_MAP) ; + ("EMPTY_SET", I_EMPTY_SET) ; + ("EQ", I_EQ) ; + ("EXEC", I_EXEC) ; + ("FAILWITH", I_FAILWITH) ; + ("GE", I_GE) ; + ("GET", I_GET) ; + ("GT", I_GT) ; + ("HASH_KEY", I_HASH_KEY) ; + ("IF", I_IF) ; + ("IF_CONS", I_IF_CONS) ; + ("IF_LEFT", I_IF_LEFT) ; + ("IF_NONE", I_IF_NONE) ; + ("INT", I_INT) ; + ("LAMBDA", I_LAMBDA) ; + ("LE", I_LE) ; + ("LEFT", I_LEFT) ; + ("LOOP", I_LOOP) ; + ("LSL", I_LSL) ; + ("LSR", I_LSR) ; + ("LT", I_LT) ; + ("MAP", I_MAP) ; + ("MEM", I_MEM) ; + ("MUL", I_MUL) ; + ("NEG", I_NEG) ; + ("NEQ", I_NEQ) ; + ("NIL", I_NIL) ; + ("NONE", I_NONE) ; + ("NOT", I_NOT) ; + ("NOW", I_NOW) ; + ("OR", I_OR) ; + ("PAIR", I_PAIR) ; + ("PUSH", I_PUSH) ; + ("RIGHT", I_RIGHT) ; + ("SIZE", I_SIZE) ; + ("SOME", I_SOME) ; + ("SOURCE", I_SOURCE) ; + ("SENDER", I_SENDER) ; + ("SELF", I_SELF) ; + ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ; + ("SUB", I_SUB) ; + ("SWAP", I_SWAP) ; + ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ; + ("SET_DELEGATE", I_SET_DELEGATE) ; + ("UNIT", I_UNIT) ; + ("UPDATE", I_UPDATE) ; + ("XOR", I_XOR) ; + ("ITER", I_ITER) ; + ("LOOP_LEFT", I_LOOP_LEFT) ; + ("ADDRESS", I_ADDRESS) ; + ("CONTRACT", I_CONTRACT) ; + ("ISNAT", I_ISNAT) ; + ("CAST", I_CAST) ; + ("RENAME", I_RENAME) ; + ("bool", T_bool) ; + ("contract", T_contract) ; + ("int", T_int) ; + ("key", T_key) ; + ("key_hash", T_key_hash) ; + ("lambda", T_lambda) ; + ("list", T_list) ; + ("map", T_map) ; + ("big_map", T_big_map) ; + ("nat", T_nat) ; + ("option", T_option) ; + ("or", T_or) ; + ("pair", T_pair) ; + ("set", T_set) ; + ("signature", T_signature) ; + ("string", T_string) ; + ("bytes", T_bytes) ; + ("mutez", T_mutez) ; + ("timestamp", T_timestamp) ; + ("unit", T_unit) ; + ("operation", T_operation) ; + ("address", T_address) ; + (* Alpha_002 addition *) + ("SLICE", I_SLICE) ; + ] + +let () = + register_error_kind + `Permanent + ~id:"michelson_v1.unknown_primitive_name" + ~title: "Unknown primitive name" + ~description: + "In a script or data expression, a primitive was unknown." + ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) + Data_encoding.(obj1 (req "wrong_primitive_name" string)) + (function + | Unknown_primitive_name got -> Some got + | _ -> None) + (fun got -> + Unknown_primitive_name got) ; + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive_name_case" + ~title: "Invalid primitive name case" + ~description: + "In a script or data expression, a primitive name is \ + neither uppercase, lowercase or capitalized." + ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n) + Data_encoding.(obj1 (req "wrong_primitive_name" string)) + (function + | Invalid_case name -> Some name + | _ -> None) + (fun name -> + Invalid_case name) ; + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive_name" + ~title: "Invalid primitive name" + ~description: + "In a script or data expression, a primitive name is \ + unknown or has a wrong case." + ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.") + Data_encoding.(obj2 + (req "expression" (Micheline.canonical_encoding ~variant:"generic" string)) + (req "location" Micheline.canonical_location_encoding)) + (function + | Invalid_primitive_name (expr, loc) -> Some (expr, loc) + | _ -> None) + (fun (expr, loc) -> + Invalid_primitive_name (expr, loc)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli new file mode 100644 index 000000000..c51e8b443 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli @@ -0,0 +1,152 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Unknown_primitive_name of string (* `Permanent *) +type error += Invalid_case of string (* `Permanent *) +type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location (* `Permanent *) + +type prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + +val prim_encoding : prim Data_encoding.encoding + +val string_of_prim : prim -> string + +val prim_of_string : string -> prim tzresult + +val prims_of_strings : string Micheline.canonical -> prim Micheline.canonical tzresult + +val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical diff --git a/vendors/ligo-utils/tezos-protocol-alpha/misc.ml b/vendors/ligo-utils/tezos-protocol-alpha/misc.ml new file mode 100644 index 000000000..26be1e0eb --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/misc.ml @@ -0,0 +1,95 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type 'a lazyt = unit -> 'a +type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) +type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t + +let rec (-->) i j = (* [i; i+1; ...; j] *) + if Compare.Int.(i > j) + then [] + else i :: (succ i --> j) + +let rec (--->) i j = (* [i; i+1; ...; j] *) + if Compare.Int32.(i > j) + then [] + else i :: (Int32.succ i ---> j) + +let split delim ?(limit = max_int) path = + let l = String.length path in + let rec do_slashes acc limit i = + if Compare.Int.(i >= l) then + List.rev acc + else if Compare.Char.(String.get path i = delim) then + do_slashes acc limit (i + 1) + else + do_split acc limit i + and do_split acc limit i = + if Compare.Int.(limit <= 0) then + if Compare.Int.(i = l) then + List.rev acc + else + List.rev (String.sub path i (l - i) :: acc) + else + do_component acc (pred limit) i i + and do_component acc limit i j = + if Compare.Int.(j >= l) then + if Compare.Int.(i = j) then + List.rev acc + else + List.rev (String.sub path i (j - i) :: acc) + else if Compare.Char.(String.get path j = delim) then + do_slashes (String.sub path i (j - i) :: acc) limit j + else + do_component acc limit i (j + 1) in + if Compare.Int.(limit > 0) then + do_slashes [] limit 0 + else + [ path ] + +let pp_print_paragraph ppf description = + Format.fprintf ppf "@[%a@]" + Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string) + (split ' ' description) + +let take n l = + let rec loop acc n = function + | xs when Compare.Int.(n <= 0) -> Some (List.rev acc, xs) + | [] -> None + | x :: xs -> loop (x :: acc) (n-1) xs in + loop [] n l + +let remove_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then + Some (String.sub s x (n - x)) + else + None + +let rec remove_elem_from_list nb = function + | [] -> [] + | l when Compare.Int.(nb <= 0) -> l + | _ :: tl -> remove_elem_from_list (nb - 1) tl diff --git a/vendors/ligo-utils/tezos-protocol-alpha/misc.mli b/vendors/ligo-utils/tezos-protocol-alpha/misc.mli new file mode 100644 index 000000000..6e359e0b4 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/misc.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {2 Stuff} ****************************************************************) + +type 'a lazyt = unit -> 'a +type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) +type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t + +(** Include bounds *) +val (-->) : int -> int -> int list +val (--->) : Int32.t -> Int32.t -> Int32.t list + +val pp_print_paragraph : Format.formatter -> string -> unit + +val take: int -> 'a list -> ('a list * 'a list) option + +(** Some (input with [prefix] removed), if string has [prefix], else [None] **) +val remove_prefix: prefix:string -> string -> string option + +(** [remove nb list] remove the first [nb] elements from the list [list]. *) +val remove_elem_from_list: int -> 'a list -> 'a list diff --git a/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml new file mode 100644 index 000000000..931011a92 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml @@ -0,0 +1,37 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* 32 *) +let nonce_hash = "\069\220\169" (* nce(53) *) + +include Blake2B.Make(Base58)(struct + let name = "cycle_nonce" + let title = "A nonce hash" + let b58check_prefix = nonce_hash + let size = None + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "nce" 53 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml new file mode 100644 index 000000000..2a43e2d9c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml @@ -0,0 +1,121 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Seed_repr.nonce +type nonce = t +let encoding = Seed_repr.nonce_encoding + +type error += + | Too_late_revelation + | Too_early_revelation + | Previously_revealed_nonce + | Unexpected_nonce + +let () = + register_error_kind + `Branch + ~id:"nonce.too_late_revelation" + ~title:"Too late nonce revelation" + ~description:"Nonce revelation happens too late" + ~pp: (fun ppf () -> + Format.fprintf ppf "This nonce cannot be revealed anymore.") + Data_encoding.unit + (function Too_late_revelation -> Some () | _ -> None) + (fun () -> Too_late_revelation) ; + register_error_kind + `Temporary + ~id:"nonce.too_early_revelation" + ~title:"Too early nonce revelation" + ~description:"Nonce revelation happens before cycle end" + ~pp: (fun ppf () -> + Format.fprintf ppf "This nonce should not yet be revealed") + Data_encoding.unit + (function Too_early_revelation -> Some () | _ -> None) + (fun () -> Too_early_revelation) ; + register_error_kind + `Branch + ~id:"nonce.previously_revealed" + ~title:"Previously revealed nonce" + ~description:"Duplicated revelation for a nonce." + ~pp: (fun ppf () -> + Format.fprintf ppf "This nonce was previously revealed") + Data_encoding.unit + (function Previously_revealed_nonce -> Some () | _ -> None) + (fun () -> Previously_revealed_nonce) ; + register_error_kind + `Branch + ~id:"nonce.unexpected" + ~title:"Unexpected nonce" + ~description:"The provided nonce is inconsistent with the committed nonce hash." + ~pp: (fun ppf () -> + Format.fprintf ppf "This nonce revelation is invalid (inconsistent with the committed hash)") + Data_encoding.unit + (function Unexpected_nonce -> Some () | _ -> None) + (fun () -> Unexpected_nonce) + +(* checks that the level of a revelation is not too early or too late wrt to the + current context and that a nonce has not been already revealed for that level *) +let get_unrevealed ctxt level = + let cur_level = Level_storage.current ctxt in + match Cycle_repr.pred cur_level.cycle with + | None -> fail Too_early_revelation (* no revelations during cycle 0 *) + | Some revealed_cycle -> + if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then + fail Too_early_revelation + else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then + fail Too_late_revelation + else + Storage.Seed.Nonce.get ctxt level >>=? function + | Revealed _ -> fail Previously_revealed_nonce + | Unrevealed status -> return status + +let record_hash ctxt unrevealed = + let level = Level_storage.current ctxt in + Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed) + +let reveal ctxt level nonce = + get_unrevealed ctxt level >>=? fun unrevealed -> + fail_unless + (Seed_repr.check_hash nonce unrevealed.nonce_hash) + Unexpected_nonce >>=? fun () -> + Storage.Seed.Nonce.set ctxt level (Revealed nonce) >>=? fun ctxt -> + return ctxt + +type unrevealed = Storage.Seed.unrevealed_nonce = { + nonce_hash: Nonce_hash.t ; + delegate: Signature.Public_key_hash.t ; + rewards: Tez_repr.t ; + fees: Tez_repr.t ; +} + +type status = Storage.Seed.nonce_status = + | Unrevealed of unrevealed + | Revealed of Seed_repr.nonce + +let get = Storage.Seed.Nonce.get + +let of_bytes = Seed_repr.make_nonce +let hash = Seed_repr.hash +let check_hash = Seed_repr.check_hash diff --git a/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli new file mode 100644 index 000000000..026f9a4e2 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli @@ -0,0 +1,57 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Too_late_revelation + | Too_early_revelation + | Previously_revealed_nonce + | Unexpected_nonce + +type t = Seed_repr.nonce +type nonce = t +val encoding: nonce Data_encoding.t + +type unrevealed = Storage.Seed.unrevealed_nonce = { + nonce_hash: Nonce_hash.t ; + delegate: Signature.Public_key_hash.t ; + rewards: Tez_repr.t ; + fees: Tez_repr.t ; +} + +type status = + | Unrevealed of unrevealed + | Revealed of Seed_repr.nonce + +val get: Raw_context.t -> Level_repr.t -> status tzresult Lwt.t + +val record_hash: + Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t + +val reveal: + Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t + +val of_bytes: MBytes.t -> nonce tzresult +val hash: nonce -> Nonce_hash.t +val check_hash: nonce -> Nonce_hash.t -> bool diff --git a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml new file mode 100644 index 000000000..17a62d71c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml @@ -0,0 +1,765 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Operations *) + +module Kind = struct + type seed_nonce_revelation = Seed_nonce_revelation_kind + type double_endorsement_evidence = Double_endorsement_evidence_kind + type double_baking_evidence = Double_baking_evidence_kind + type activate_account = Activate_account_kind + type endorsement = Endorsement_kind + type proposals = Proposals_kind + type ballot = Ballot_kind + type reveal = Reveal_kind + type transaction = Transaction_kind + type origination = Origination_kind + type delegation = Delegation_kind + type 'a manager = + | Reveal_manager_kind : reveal manager + | Transaction_manager_kind : transaction manager + | Origination_manager_kind : origination manager + | Delegation_manager_kind : delegation manager +end + +type raw = Operation.t = { + shell: Operation.shell_header ; + proto: MBytes.t ; +} + +let raw_encoding = Operation.encoding + +type 'kind operation = { + shell: Operation.shell_header ; + protocol_data: 'kind protocol_data ; +} + +and 'kind protocol_data = { + contents: 'kind contents_list ; + signature: Signature.t option ; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : 'kind Kind.manager contents * 'rest Kind.manager contents_list -> + (('kind * 'rest) Kind.manager ) contents_list + +and _ contents = + | Endorsement : { + level: Raw_level_repr.t ; + } -> Kind.endorsement contents + | Seed_nonce_revelation : { + level: Raw_level_repr.t ; + nonce: Seed_repr.nonce ; + } -> Kind.seed_nonce_revelation contents + | Double_endorsement_evidence : { + op1: Kind.endorsement operation ; + op2: Kind.endorsement operation ; + } -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1: Block_header_repr.t ; + bh2: Block_header_repr.t ; + } -> Kind.double_baking_evidence contents + | Activate_account : { + id: Ed25519.Public_key_hash.t ; + activation_code: Blinded_public_key_hash.activation_code ; + } -> Kind.activate_account contents + | Proposals : { + source: Signature.Public_key_hash.t ; + period: Voting_period_repr.t ; + proposals: Protocol_hash.t list ; + } -> Kind.proposals contents + | Ballot : { + source: Signature.Public_key_hash.t ; + period: Voting_period_repr.t ; + proposal: Protocol_hash.t ; + ballot: Vote_repr.ballot ; + } -> Kind.ballot contents + | Manager_operation : { + source: Contract_repr.contract ; + fee: Tez_repr.tez ; + counter: counter ; + operation: 'kind manager_operation ; + gas_limit: Z.t; + storage_limit: Z.t; + } -> 'kind Kind.manager contents + +and _ manager_operation = + | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation + | Transaction : { + amount: Tez_repr.tez ; + parameters: Script_repr.lazy_expr option ; + destination: Contract_repr.contract ; + } -> Kind.transaction manager_operation + | Origination : { + manager: Signature.Public_key_hash.t ; + delegate: Signature.Public_key_hash.t option ; + script: Script_repr.t option ; + spendable: bool ; + delegatable: bool ; + credit: Tez_repr.tez ; + preorigination: Contract_repr.t option ; + } -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option -> Kind.delegation manager_operation + +and counter = Z.t + +let manager_kind : type kind. kind manager_operation -> kind Kind.manager = + function + | Reveal _ -> Kind.Reveal_manager_kind + | Transaction _ -> Kind.Transaction_manager_kind + | Origination _ -> Kind.Origination_manager_kind + | Delegation _ -> Kind.Delegation_manager_kind + +type 'kind internal_operation = { + source: Contract_repr.contract ; + operation: 'kind manager_operation ; + nonce: int ; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +type packed_contents = + | Contents : 'kind contents -> packed_contents + +type packed_contents_list = + | Contents_list : 'kind contents_list -> packed_contents_list + +type packed_protocol_data = + | Operation_data : 'kind protocol_data -> packed_protocol_data + +type packed_operation = { + shell: Operation.shell_header ; + protocol_data: packed_protocol_data ; +} + +let pack ({ shell ; protocol_data} : _ operation) : packed_operation = { + shell ; + protocol_data = Operation_data protocol_data ; +} + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +let rec to_list = function + | Contents_list (Single o) -> [Contents o] + | Contents_list (Cons (o, os)) -> + Contents o :: to_list (Contents_list os) + +let rec of_list = function + | [] -> assert false + | [Contents o] -> Contents_list (Single o) + | (Contents o) :: os -> + let Contents_list os = of_list os in + match o, os with + | Manager_operation _, Single (Manager_operation _) -> + Contents_list (Cons (o, os)) + | Manager_operation _, Cons _ -> + Contents_list (Cons (o, os)) + | _ -> + Pervasives.failwith "Operation list of length > 1 \ + should only contains manager operations." + +module Encoding = struct + + open Data_encoding + + let case tag name args proj inj = + let open Data_encoding in + case tag + ~title:(String.capitalize_ascii name) + (merge_objs + (obj1 (req "kind" (constant name))) + args) + (fun x -> match proj x with None -> None | Some x -> Some ((), x)) + (fun ((), x) -> inj x) + + module Manager_operations = struct + + type 'kind case = + MCase : { tag: int ; + name: string ; + encoding: 'a Data_encoding.t ; + select: packed_manager_operation -> 'kind manager_operation option ; + proj: 'kind manager_operation -> 'a ; + inj: 'a -> 'kind manager_operation } -> 'kind case + + let reveal_case = + MCase { + tag = 0 ; + name = "reveal" ; + encoding = + (obj1 + (req "public_key" Signature.Public_key.encoding)) ; + select = + (function + | Manager (Reveal _ as op) -> Some op + | _ -> None) ; + proj = + (function Reveal pkh -> pkh) ; + inj = + (fun pkh -> Reveal pkh) + } + + let transaction_case = + MCase { + tag = 1 ; + name = "transaction" ; + encoding = + (obj3 + (req "amount" Tez_repr.encoding) + (req "destination" Contract_repr.encoding) + (opt "parameters" Script_repr.lazy_expr_encoding)) ; + select = + (function + | Manager (Transaction _ as op) -> Some op + | _ -> None) ; + proj = + (function + | Transaction { amount ; destination ; parameters } -> + (amount, destination, parameters)) ; + inj = + (fun (amount, destination, parameters) -> + Transaction { amount ; destination ; parameters }) + } + + let origination_case = + MCase { + tag = 2 ; + name = "origination" ; + encoding = + (obj6 + (req "manager_pubkey" Signature.Public_key_hash.encoding) + (req "balance" Tez_repr.encoding) + (dft "spendable" bool true) + (dft "delegatable" bool true) + (opt "delegate" Signature.Public_key_hash.encoding) + (opt "script" Script_repr.encoding)) ; + select = + (function + | Manager (Origination _ as op) -> Some op + | _ -> None) ; + proj = + (function + | Origination { manager ; credit ; spendable ; + delegatable ; delegate ; script ; + preorigination = _ + (* the hash is only used internally + when originating from smart + contracts, don't serialize it *) } -> + (manager, credit, spendable, + delegatable, delegate, script)) ; + inj = + (fun (manager, credit, spendable, delegatable, delegate, script) -> + Origination + {manager ; credit ; spendable ; delegatable ; + delegate ; script ; preorigination = None }) + } + + let delegation_case = + MCase { + tag = 3 ; + name = "delegation" ; + encoding = + (obj1 + (opt "delegate" Signature.Public_key_hash.encoding)) ; + select = + (function + | Manager (Delegation _ as op) -> Some op + | _ -> None) ; + proj = + (function Delegation key -> key) ; + inj = + (fun key -> Delegation key) + } + + let encoding = + let make (MCase { tag ; name ; encoding ; select ; proj ; inj }) = + case (Tag tag) name encoding + (fun o -> match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Manager (inj x)) in + union ~tag_size:`Uint8 [ + make reveal_case ; + make transaction_case ; + make origination_case ; + make delegation_case ; + ] + + end + + type 'b case = + Case : { tag: int ; + name: string ; + encoding: 'a Data_encoding.t ; + select: packed_contents -> 'b contents option ; + proj: 'b contents -> 'a ; + inj: 'a -> 'b contents } -> 'b case + + let endorsement_encoding = + obj1 + (req "level" Raw_level_repr.encoding) + + let endorsement_case = + Case { + tag = 0 ; + name = "endorsement" ; + encoding = endorsement_encoding ; + select = + (function + | Contents (Endorsement _ as op) -> Some op + | _ -> None) ; + proj = + (fun (Endorsement { level }) -> level) ; + inj = + (fun level -> Endorsement { level }) + } + + let endorsement_encoding = + let make (Case { tag ; name ; encoding ; select = _ ; proj ; inj }) = + case (Tag tag) name encoding + (fun o -> Some (proj o)) + (fun x -> inj x) in + let to_list : Kind.endorsement contents_list -> _ = function + | Single o -> o in + let of_list : Kind.endorsement contents -> _ = function + | o -> Single o in + def "inlined.endorsement" @@ + conv + (fun ({ shell ; protocol_data = { contents ; signature } } : _ operation)-> + (shell, (contents, signature))) + (fun (shell, (contents, signature)) -> + ({ shell ; protocol_data = { contents ; signature }} : _ operation)) + (merge_objs + Operation.shell_header_encoding + (obj2 + (req "operations" + (conv to_list of_list @@ + def "inlined.endorsement.contents" @@ + union [ + make endorsement_case ; + ])) + (varopt "signature" Signature.encoding))) + + let seed_nonce_revelation_case = + Case { + tag = 1; + name = "seed_nonce_revelation" ; + encoding = + (obj2 + (req "level" Raw_level_repr.encoding) + (req "nonce" Seed_repr.nonce_encoding)) ; + select = + (function + | Contents (Seed_nonce_revelation _ as op) -> Some op + | _ -> None) ; + proj = + (fun (Seed_nonce_revelation { level ; nonce }) -> (level, nonce)) ; + inj = + (fun (level, nonce) -> Seed_nonce_revelation { level ; nonce }) + } + + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case = + Case { + tag = 2 ; + name = "double_endorsement_evidence" ; + encoding = + (obj2 + (req "op1" (dynamic_size endorsement_encoding)) + (req "op2" (dynamic_size endorsement_encoding))) ; + select = + (function + | Contents (Double_endorsement_evidence _ as op) -> Some op + | _ -> None) ; + proj = + (fun (Double_endorsement_evidence { op1 ; op2 }) -> (op1, op2)) ; + inj = + (fun (op1, op2) -> (Double_endorsement_evidence { op1 ; op2 })) + } + + let double_baking_evidence_case = + Case { + tag = 3 ; + name = "double_baking_evidence" ; + encoding = + (obj2 + (req "bh1" (dynamic_size Block_header_repr.encoding)) + (req "bh2" (dynamic_size Block_header_repr.encoding))) ; + select = + (function + | Contents (Double_baking_evidence _ as op) -> Some op + | _ -> None) ; + proj = + (fun (Double_baking_evidence { bh1 ; bh2 }) -> (bh1, bh2)) ; + inj = + (fun (bh1, bh2) -> Double_baking_evidence { bh1 ; bh2 }) ; + } + + let activate_account_case = + Case { + tag = 4 ; + name = "activate_account" ; + encoding = + (obj2 + (req "pkh" Ed25519.Public_key_hash.encoding) + (req "secret" Blinded_public_key_hash.activation_code_encoding)) ; + select = + (function + | Contents (Activate_account _ as op) -> Some op + | _ -> None) ; + proj = + (fun (Activate_account { id ; activation_code }) -> (id, activation_code)) ; + inj = + (fun (id, activation_code) -> Activate_account { id ; activation_code }) + } + + let proposals_case = + Case { + tag = 5 ; + name = "proposals" ; + encoding = + (obj3 + (req "source" Signature.Public_key_hash.encoding) + (req "period" Voting_period_repr.encoding) + (req "proposals" (list Protocol_hash.encoding))) ; + select = + (function + | Contents (Proposals _ as op) -> Some op + | _ -> None) ; + proj = + (fun (Proposals { source ; period ; proposals }) -> + (source, period, proposals)) ; + inj = + (fun (source, period, proposals) -> + Proposals { source ; period ; proposals }) ; + } + + let ballot_case = + Case { + tag = 6 ; + name = "ballot" ; + encoding = + (obj4 + (req "source" Signature.Public_key_hash.encoding) + (req "period" Voting_period_repr.encoding) + (req "proposal" Protocol_hash.encoding) + (req "ballot" Vote_repr.ballot_encoding)) ; + select = + (function + | Contents (Ballot _ as op) -> Some op + | _ -> None) ; + proj = + (function + (Ballot { source ; period ; proposal ; ballot }) -> + (source, period, proposal, ballot)) ; + inj = + (fun (source, period, proposal, ballot) -> + Ballot { source ; period ; proposal ; ballot }) ; + } + + let manager_encoding = + (obj5 + (req "source" Contract_repr.encoding) + (req "fee" Tez_repr.encoding) + (req "counter" (check_size 10 n)) + (req "gas_limit" (check_size 10 n)) + (req "storage_limit" (check_size 10 n))) + + let extract + (type kind) + (Manager_operation { source ; fee ; counter ; + gas_limit ; storage_limit ; operation = _ } : kind Kind.manager contents) = + (source, fee, counter, gas_limit, storage_limit) + + let rebuild (source, fee, counter, gas_limit, storage_limit) operation = + Manager_operation { source ; fee ; counter ; + gas_limit ; storage_limit ; operation } + + let make_manager_case tag + (type kind) + (Manager_operations.MCase mcase : kind Manager_operations.case) = + Case { + tag ; + name = mcase.name ; + encoding = + merge_objs + manager_encoding + mcase.encoding ; + select = + (function + | Contents (Manager_operation ({ operation ; _ } as op)) -> begin + match mcase.select (Manager operation) with + | None -> None + | Some operation -> + Some (Manager_operation { op with operation }) + end + | _ -> None) ; + proj = + (function + | Manager_operation { operation ; _ } as op -> + (extract op, mcase.proj operation )) ; + inj = + (fun (op, contents) -> + (rebuild op (mcase.inj contents))) + } + + let reveal_case = make_manager_case 7 Manager_operations.reveal_case + let transaction_case = make_manager_case 8 Manager_operations.transaction_case + let origination_case = make_manager_case 9 Manager_operations.origination_case + let delegation_case = make_manager_case 10 Manager_operations.delegation_case + + let contents_encoding = + let make (Case { tag ; name ; encoding ; select ; proj ; inj }) = + case (Tag tag) name encoding + (fun o -> match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Contents (inj x)) in + def "operation.alpha.contents" @@ + union [ + make endorsement_case ; + make seed_nonce_revelation_case ; + make double_endorsement_evidence_case ; + make double_baking_evidence_case ; + make activate_account_case ; + make proposals_case ; + make ballot_case ; + make reveal_case ; + make transaction_case ; + make origination_case ; + make delegation_case ; + ] + + let contents_list_encoding = + conv to_list of_list (Variable.list contents_encoding) + + let optional_signature_encoding = + conv + (function Some s -> s | None -> Signature.zero) + (fun s -> if Signature.equal s Signature.zero then None else Some s) + Signature.encoding + + let protocol_data_encoding = + def "operation.alpha.contents_and_signature" @@ + conv + (fun (Operation_data { contents ; signature }) -> + (Contents_list contents, signature)) + (fun (Contents_list contents, signature) -> + Operation_data { contents ; signature }) + (obj2 + (req "contents" contents_list_encoding) + (req "signature" optional_signature_encoding)) + + let operation_encoding = + conv + (fun ({ shell ; protocol_data }) -> + (shell, protocol_data)) + (fun (shell, protocol_data) -> + { shell ; protocol_data }) + (merge_objs + Operation.shell_header_encoding + protocol_data_encoding) + + let unsigned_operation_encoding = + def "operation.alpha.unsigned_operation" @@ + merge_objs + Operation.shell_header_encoding + (obj1 (req "contents" contents_list_encoding)) + + let internal_operation_encoding = + def "operation.alpha.internal_operation" @@ + conv + (fun (Internal_operation { source ; operation ; nonce }) -> + ((source, nonce), Manager operation)) + (fun ((source, nonce), Manager operation) -> + Internal_operation { source ; operation ; nonce }) + (merge_objs + (obj2 + (req "source" Contract_repr.encoding) + (req "nonce" uint16)) + Manager_operations.encoding) + +end + +let encoding = Encoding.operation_encoding +let contents_encoding = Encoding.contents_encoding +let contents_list_encoding = Encoding.contents_list_encoding +let protocol_data_encoding = Encoding.protocol_data_encoding +let unsigned_operation_encoding = Encoding.unsigned_operation_encoding +let internal_operation_encoding = Encoding.internal_operation_encoding + +let raw ({ shell ; protocol_data } : _ operation) = + let proto = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + (Operation_data protocol_data) in + { Operation.shell ; proto } + +let acceptable_passes (op : packed_operation) = + let Operation_data protocol_data = op.protocol_data in + match protocol_data.contents with + + | Single (Endorsement _) -> [0] + + | Single (Proposals _ ) -> [1] + | Single (Ballot _ ) -> [1] + + | Single (Seed_nonce_revelation _) -> [2] + | Single (Double_endorsement_evidence _) -> [2] + | Single (Double_baking_evidence _) -> [2] + | Single (Activate_account _) -> [2] + + | Single (Manager_operation _) -> [3] + | Cons _ -> [3] + +type error += Invalid_signature (* `Permanent *) +type error += Missing_signature (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"operation.invalid_signature" + ~title:"Invalid operation signature" + ~description:"The operation signature is ill-formed \ + or has been made with the wrong public key" + ~pp:(fun ppf () -> + Format.fprintf ppf "The operation signature is invalid") + Data_encoding.unit + (function Invalid_signature -> Some () | _ -> None) + (fun () -> Invalid_signature) ; + register_error_kind + `Permanent + ~id:"operation.missing_signature" + ~title:"Missing operation signature" + ~description:"The operation is of a kind that must be signed, \ + but the signature is missing" + ~pp:(fun ppf () -> + Format.fprintf ppf "The operation requires a signature") + Data_encoding.unit + (function Missing_signature -> Some () | _ -> None) + (fun () -> Missing_signature) + +let check_signature_sync (type kind) key chain_id ({ shell ; protocol_data } : kind operation) = + let check ~watermark contents signature = + let unsigned_operation = + Data_encoding.Binary.to_bytes_exn + unsigned_operation_encoding (shell, contents) in + if Signature.check ~watermark key signature unsigned_operation then + Ok () + else + Error [Invalid_signature] in + match protocol_data.contents, protocol_data.signature with + | Single _, None -> + Error [Missing_signature] + | Cons _, None -> + Error [Missing_signature] + | Single (Endorsement _) as contents, Some signature -> + check ~watermark:(Endorsement chain_id) (Contents_list contents) signature + | Single _ as contents, Some signature -> + check ~watermark:Generic_operation (Contents_list contents) signature + | Cons _ as contents, Some signature -> + check ~watermark:Generic_operation (Contents_list contents) signature + +let check_signature pk chain_id op = + Lwt.return (check_signature_sync pk chain_id op) + +let hash_raw = Operation.hash +let hash (o : _ operation) = + let proto = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + (Operation_data o.protocol_data) in + Operation.hash { shell = o.shell ; proto } +let hash_packed (o : packed_operation) = + let proto = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + o.protocol_data in + Operation.hash { shell = o.shell ; proto } + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +let equal_manager_operation_kind + : type a b. a manager_operation -> b manager_operation -> (a, b) eq option + = fun op1 op2 -> + match op1, op2 with + | Reveal _, Reveal _ -> Some Eq + | Reveal _, _ -> None + | Transaction _, Transaction _ -> Some Eq + | Transaction _, _ -> None + | Origination _, Origination _ -> Some Eq + | Origination _, _ -> None + | Delegation _, Delegation _ -> Some Eq + | Delegation _, _ -> None + +let equal_contents_kind + : type a b. a contents -> b contents -> (a, b) eq option + = fun op1 op2 -> + match op1, op2 with + | Endorsement _, Endorsement _ -> Some Eq + | Endorsement _, _ -> None + | Seed_nonce_revelation _, Seed_nonce_revelation _ -> Some Eq + | Seed_nonce_revelation _, _ -> None + | Double_endorsement_evidence _, Double_endorsement_evidence _ -> Some Eq + | Double_endorsement_evidence _, _ -> None + | Double_baking_evidence _, Double_baking_evidence _ -> Some Eq + | Double_baking_evidence _, _ -> None + | Activate_account _, Activate_account _ -> Some Eq + | Activate_account _, _ -> None + | Proposals _, Proposals _ -> Some Eq + | Proposals _, _ -> None + | Ballot _, Ballot _ -> Some Eq + | Ballot _, _ -> None + | Manager_operation op1, Manager_operation op2 -> begin + match equal_manager_operation_kind op1.operation op2.operation with + | None -> None + | Some Eq -> Some Eq + end + | Manager_operation _, _ -> None + +let rec equal_contents_kind_list + : type a b. a contents_list -> b contents_list -> (a, b) eq option + = fun op1 op2 -> + match op1, op2 with + | Single op1, Single op2 -> + equal_contents_kind op1 op2 + | Single _, Cons _ -> None + | Cons _, Single _ -> None + | Cons (op1, ops1), Cons (op2, ops2) -> begin + match equal_contents_kind op1 op2 with + | None -> None + | Some Eq -> + match equal_contents_kind_list ops1 ops2 with + | None -> None + | Some Eq -> Some Eq + end + +let equal + : type a b. a operation -> b operation -> (a, b) eq option + = fun op1 op2 -> + if not (Operation_hash.equal (hash op1) (hash op2)) then + None + else + equal_contents_kind_list + op1.protocol_data.contents op2.protocol_data.contents diff --git a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli new file mode 100644 index 000000000..fe1dcb754 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli @@ -0,0 +1,232 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Operations *) + +module Kind : sig + type seed_nonce_revelation = Seed_nonce_revelation_kind + type double_endorsement_evidence = Double_endorsement_evidence_kind + type double_baking_evidence = Double_baking_evidence_kind + type activate_account = Activate_account_kind + type endorsement = Endorsement_kind + type proposals = Proposals_kind + type ballot = Ballot_kind + type reveal = Reveal_kind + type transaction = Transaction_kind + type origination = Origination_kind + type delegation = Delegation_kind + type 'a manager = + | Reveal_manager_kind : reveal manager + | Transaction_manager_kind : transaction manager + | Origination_manager_kind : origination manager + | Delegation_manager_kind : delegation manager + +end + +type raw = Operation.t = { + shell: Operation.shell_header ; + proto: MBytes.t ; +} + +val raw_encoding: raw Data_encoding.t + +type 'kind operation = { + shell: Operation.shell_header ; + protocol_data: 'kind protocol_data ; +} + +and 'kind protocol_data = { + contents: 'kind contents_list ; + signature: Signature.t option ; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : 'kind Kind.manager contents * 'rest Kind.manager contents_list -> + (('kind * 'rest) Kind.manager ) contents_list + +and _ contents = + | Endorsement : { + level: Raw_level_repr.t ; + } -> Kind.endorsement contents + | Seed_nonce_revelation : { + level: Raw_level_repr.t ; + nonce: Seed_repr.nonce ; + } -> Kind.seed_nonce_revelation contents + | Double_endorsement_evidence : { + op1: Kind.endorsement operation ; + op2: Kind.endorsement operation ; + } -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1: Block_header_repr.t ; + bh2: Block_header_repr.t ; + } -> Kind.double_baking_evidence contents + | Activate_account : { + id: Ed25519.Public_key_hash.t ; + activation_code: Blinded_public_key_hash.activation_code ; + } -> Kind.activate_account contents + | Proposals : { + source: Signature.Public_key_hash.t ; + period: Voting_period_repr.t ; + proposals: Protocol_hash.t list ; + } -> Kind.proposals contents + | Ballot : { + source: Signature.Public_key_hash.t ; + period: Voting_period_repr.t ; + proposal: Protocol_hash.t ; + ballot: Vote_repr.ballot ; + } -> Kind.ballot contents + | Manager_operation : { + source: Contract_repr.contract ; + fee: Tez_repr.tez ; + counter: counter ; + operation: 'kind manager_operation ; + gas_limit: Z.t; + storage_limit: Z.t; + } -> 'kind Kind.manager contents + +and _ manager_operation = + | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation + | Transaction : { + amount: Tez_repr.tez ; + parameters: Script_repr.lazy_expr option ; + destination: Contract_repr.contract ; + } -> Kind.transaction manager_operation + | Origination : { + manager: Signature.Public_key_hash.t ; + delegate: Signature.Public_key_hash.t option ; + script: Script_repr.t option ; + spendable: bool ; + delegatable: bool ; + credit: Tez_repr.tez ; + preorigination: Contract_repr.t option ; + } -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option -> Kind.delegation manager_operation + +and counter = Z.t + +type 'kind internal_operation = { + source: Contract_repr.contract ; + operation: 'kind manager_operation ; + nonce: int ; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +type packed_contents = + | Contents : 'kind contents -> packed_contents + +type packed_contents_list = + | Contents_list : 'kind contents_list -> packed_contents_list + +val of_list: packed_contents list -> packed_contents_list +val to_list: packed_contents_list -> packed_contents list + +type packed_protocol_data = + | Operation_data : 'kind protocol_data -> packed_protocol_data + +type packed_operation = { + shell: Operation.shell_header ; + protocol_data: packed_protocol_data ; +} + +val pack: 'kind operation -> packed_operation + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +val manager_kind: 'kind manager_operation -> 'kind Kind.manager + +val encoding: packed_operation Data_encoding.t +val contents_encoding: packed_contents Data_encoding.t +val contents_list_encoding: packed_contents_list Data_encoding.t +val protocol_data_encoding: packed_protocol_data Data_encoding.t +val unsigned_operation_encoding: (Operation.shell_header * packed_contents_list) Data_encoding.t + +val raw: _ operation -> raw + +val hash_raw: raw -> Operation_hash.t +val hash: _ operation -> Operation_hash.t +val hash_packed: packed_operation -> Operation_hash.t + +val acceptable_passes: packed_operation -> int list + +type error += Missing_signature (* `Permanent *) +type error += Invalid_signature (* `Permanent *) + +val check_signature: + Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult Lwt.t +val check_signature_sync: + Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult + + +val internal_operation_encoding: + packed_internal_operation Data_encoding.t + +type ('a, 'b) eq = Eq : ('a, 'a) eq +val equal: 'a operation -> 'b operation -> ('a, 'b) eq option + +module Encoding : sig + + type 'b case = + Case : { tag: int ; + name: string ; + encoding: 'a Data_encoding.t ; + select: packed_contents -> 'b contents option ; + proj: 'b contents -> 'a ; + inj: 'a -> 'b contents } -> 'b case + + val endorsement_case: Kind.endorsement case + val seed_nonce_revelation_case: Kind.seed_nonce_revelation case + val double_endorsement_evidence_case: Kind.double_endorsement_evidence case + val double_baking_evidence_case: Kind.double_baking_evidence case + val activate_account_case: Kind.activate_account case + val proposals_case: Kind.proposals case + val ballot_case: Kind.ballot case + val reveal_case: Kind.reveal Kind.manager case + val transaction_case: Kind.transaction Kind.manager case + val origination_case: Kind.origination Kind.manager case + val delegation_case: Kind.delegation Kind.manager case + + module Manager_operations : sig + + type 'b case = + MCase : { tag: int ; + name: string ; + encoding: 'a Data_encoding.t ; + select: packed_manager_operation -> 'kind manager_operation option ; + proj: 'kind manager_operation -> 'a ; + inj: 'a -> 'kind manager_operation } -> 'kind case + + val reveal_case: Kind.reveal case + val transaction_case: Kind.transaction case + val origination_case: Kind.origination case + val delegation_case: Kind.delegation case + + end + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml new file mode 100644 index 000000000..b8c7b150d --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml @@ -0,0 +1,298 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type bootstrap_account = { + public_key_hash : Signature.Public_key_hash.t ; + public_key : Signature.Public_key.t option ; + amount : Tez_repr.t ; +} + +type bootstrap_contract = { + delegate : Signature.Public_key_hash.t ; + amount : Tez_repr.t ; + script : Script_repr.t ; +} + +type t = { + bootstrap_accounts : bootstrap_account list ; + bootstrap_contracts : bootstrap_contract list ; + commitments : Commitment_repr.t list ; + constants : Constants_repr.parametric ; + security_deposit_ramp_up_cycles : int option ; + no_reward_cycles : int option ; +} + +let bootstrap_account_encoding = + let open Data_encoding in + union + [ case (Tag 0) ~title:"Public_key_known" + (tup2 + Signature.Public_key.encoding + Tez_repr.encoding) + (function + | { public_key_hash ; public_key = Some public_key ; amount } -> + assert (Signature.Public_key_hash.equal + (Signature.Public_key.hash public_key) + public_key_hash) ; + Some (public_key, amount) + | { public_key = None } -> None) + (fun (public_key, amount) -> + { public_key = Some public_key ; + public_key_hash = Signature.Public_key.hash public_key ; + amount }) ; + case (Tag 1) ~title:"Public_key_unknown" + (tup2 + Signature.Public_key_hash.encoding + Tez_repr.encoding) + (function + | { public_key_hash ; public_key = None ; amount } -> + Some (public_key_hash, amount) + | { public_key = Some _ } -> None) + (fun (public_key_hash, amount) -> + { public_key = None ; + public_key_hash ; + amount }) ] + +let bootstrap_contract_encoding = + let open Data_encoding in + conv + (fun { delegate ; amount ; script } -> (delegate, amount, script)) + (fun (delegate, amount, script) -> { delegate ; amount ; script }) + (obj3 + (req "delegate" Signature.Public_key_hash.encoding) + (req "amount" Tez_repr.encoding) + (req "script" Script_repr.encoding)) + +(* This encoding is used to read configuration files (e.g. sandbox.json) + where some fields can be missing, in that case they are replaced by + the default. *) +let constants_encoding = + let open Data_encoding in + conv + (fun (c : Constants_repr.parametric) -> + let module Compare_time_between_blocks = Compare.List (Period_repr) in + let module Compare_keys = Compare.List (Ed25519.Public_key) in + let opt (=) def v = if def = v then None else Some v in + let default = Constants_repr.default in + let preserved_cycles = + opt Compare.Int.(=) + default.preserved_cycles c.preserved_cycles + and blocks_per_cycle = + opt Compare.Int32.(=) + default.blocks_per_cycle c.blocks_per_cycle + and blocks_per_commitment = + opt Compare.Int32.(=) + default.blocks_per_commitment c.blocks_per_commitment + and blocks_per_roll_snapshot = + opt Compare.Int32.(=) + default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot + and blocks_per_voting_period = + opt Compare.Int32.(=) + default.blocks_per_voting_period c.blocks_per_voting_period + and time_between_blocks = + opt Compare_time_between_blocks.(=) + default.time_between_blocks c.time_between_blocks + and endorsers_per_block = + opt Compare.Int.(=) + default.endorsers_per_block c.endorsers_per_block + and hard_gas_limit_per_operation = + opt Compare.Z.(=) + default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation + and hard_gas_limit_per_block = + opt Compare.Z.(=) + default.hard_gas_limit_per_block c.hard_gas_limit_per_block + and proof_of_work_threshold = + opt Compare.Int64.(=) + default.proof_of_work_threshold c.proof_of_work_threshold + and tokens_per_roll = + opt Tez_repr.(=) + default.tokens_per_roll c.tokens_per_roll + and michelson_maximum_type_size = + opt Compare.Int.(=) + default.michelson_maximum_type_size c.michelson_maximum_type_size + and seed_nonce_revelation_tip = + opt Tez_repr.(=) + default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip + and origination_size = + opt Compare.Int.(=) + default.origination_size c.origination_size + and block_security_deposit = + opt Tez_repr.(=) + default.block_security_deposit c.block_security_deposit + and endorsement_security_deposit = + opt Tez_repr.(=) + default.endorsement_security_deposit c.endorsement_security_deposit + and block_reward = + opt Tez_repr.(=) + default.block_reward c.block_reward + and endorsement_reward = + opt Tez_repr.(=) + default.endorsement_reward c.endorsement_reward + and cost_per_byte = + opt Tez_repr.(=) + default.cost_per_byte c.cost_per_byte + and hard_storage_limit_per_operation = + opt Compare.Z.(=) + default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation + and test_chain_duration = + opt Compare.Int64.(=) + default.test_chain_duration c.test_chain_duration + in + (( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block), + ((proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward), + (endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration)))) + (fun (( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block), + ((proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward), + (endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration))) -> + let unopt def = function None -> def | Some v -> v in + let default = Constants_repr.default in + { Constants_repr.preserved_cycles = + unopt default.preserved_cycles preserved_cycles ; + blocks_per_cycle = + unopt default.blocks_per_cycle blocks_per_cycle ; + blocks_per_commitment = + unopt default.blocks_per_commitment blocks_per_commitment ; + blocks_per_roll_snapshot = + unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ; + blocks_per_voting_period = + unopt default.blocks_per_voting_period blocks_per_voting_period ; + time_between_blocks = + unopt default.time_between_blocks @@ + time_between_blocks ; + endorsers_per_block = + unopt default.endorsers_per_block endorsers_per_block ; + hard_gas_limit_per_operation = + unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ; + hard_gas_limit_per_block = + unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ; + proof_of_work_threshold = + unopt default.proof_of_work_threshold proof_of_work_threshold ; + tokens_per_roll = + unopt default.tokens_per_roll tokens_per_roll ; + michelson_maximum_type_size = + unopt default.michelson_maximum_type_size michelson_maximum_type_size ; + seed_nonce_revelation_tip = + unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ; + origination_size = + unopt default.origination_size origination_size ; + block_security_deposit = + unopt default.block_security_deposit block_security_deposit ; + endorsement_security_deposit = + unopt default.endorsement_security_deposit endorsement_security_deposit ; + block_reward = + unopt default.block_reward block_reward ; + endorsement_reward = + unopt default.endorsement_reward endorsement_reward ; + cost_per_byte = + unopt default.cost_per_byte cost_per_byte ; + hard_storage_limit_per_operation = + unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ; + test_chain_duration = + unopt default.test_chain_duration test_chain_duration ; + } ) + (merge_objs + (obj9 + (opt "preserved_cycles" uint8) + (opt "blocks_per_cycle" int32) + (opt "blocks_per_commitment" int32) + (opt "blocks_per_roll_snapshot" int32) + (opt "blocks_per_voting_period" int32) + (opt "time_between_blocks" (list Period_repr.encoding)) + (opt "endorsers_per_block" uint16) + (opt "hard_gas_limit_per_operation" z) + (opt "hard_gas_limit_per_block" z)) + (merge_objs + (obj8 + (opt "proof_of_work_threshold" int64) + (opt "tokens_per_roll" Tez_repr.encoding) + (opt "michelson_maximum_type_size" uint16) + (opt "seed_nonce_revelation_tip" Tez_repr.encoding) + (opt "origination_size" int31) + (opt "block_security_deposit" Tez_repr.encoding) + (opt "endorsement_security_deposit" Tez_repr.encoding) + (opt "block_reward" Tez_repr.encoding)) + (obj4 + (opt "endorsement_reward" Tez_repr.encoding) + (opt "cost_per_byte" Tez_repr.encoding) + (opt "hard_storage_limit_per_operation" z) + (opt "test_chain_duration" int64)))) + +let encoding = + let open Data_encoding in + conv + (fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; + security_deposit_ramp_up_cycles ; no_reward_cycles } -> + ((bootstrap_accounts, bootstrap_contracts, commitments, + security_deposit_ramp_up_cycles, no_reward_cycles), + constants)) + (fun ( (bootstrap_accounts, bootstrap_contracts, commitments, + security_deposit_ramp_up_cycles, no_reward_cycles), + constants) -> + { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; + security_deposit_ramp_up_cycles ; no_reward_cycles }) + (merge_objs + (obj5 + (req "bootstrap_accounts" (list bootstrap_account_encoding)) + (dft "bootstrap_contracts" (list bootstrap_contract_encoding) []) + (dft "commitments" (list Commitment_repr.encoding) []) + (opt "security_deposit_ramp_up_cycles" int31) + (opt "no_reward_cycles" int31)) + constants_encoding) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli new file mode 100644 index 000000000..458182195 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli @@ -0,0 +1,48 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type bootstrap_account = { + public_key_hash : Signature.Public_key_hash.t ; + public_key : Signature.Public_key.t option ; + amount : Tez_repr.t ; +} + +type bootstrap_contract = { + delegate : Signature.Public_key_hash.t ; + amount : Tez_repr.t ; + script : Script_repr.t ; +} + +type t = { + bootstrap_accounts : bootstrap_account list ; + bootstrap_contracts : bootstrap_contract list ; + commitments : Commitment_repr.t list ; + constants : Constants_repr.parametric ; + security_deposit_ramp_up_cycles : int option ; + no_reward_cycles : int option ; +} + +val encoding: t Data_encoding.t +val constants_encoding: Constants_repr.parametric Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml new file mode 100644 index 000000000..f1a97d561 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml @@ -0,0 +1,78 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Int64.t +type period = t +include (Compare.Int64 : Compare.S with type t := t) +let encoding = Data_encoding.int64 + +let pp ppf v = Format.fprintf ppf "%Ld" v + +type error += (* `Permanent *) + | Malformed_period + | Invalid_arg + +let () = + let open Data_encoding in + (* Malformed period *) + register_error_kind + `Permanent + ~id:"malformed_period" + ~title:"Malformed period" + ~description:"Period is negative." + ~pp:(fun ppf () -> Format.fprintf ppf "Malformed period") + empty + (function Malformed_period -> Some () | _ -> None) + (fun () -> Malformed_period) ; + (* Invalid arg *) + register_error_kind + `Permanent + ~id:"invalid_arg" + ~title:"Invalid arg" + ~description:"Negative multiple of periods are not allowed." + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid arg") + empty + (function Invalid_arg -> Some () | _ -> None) + (fun () -> Invalid_arg) + +let of_seconds t = + if Compare.Int64.(t >= 0L) + then ok t + else error Malformed_period +let to_seconds t = t +let of_seconds_exn t = + match of_seconds t with + | Ok t -> t + | _ -> invalid_arg "Period.of_seconds_exn" + +let mult i p = + (* TODO check overflow *) + if Compare.Int32.(i < 0l) + then error Invalid_arg + else ok (Int64.mul (Int64.of_int32 i) p) + +let one_second = of_seconds_exn 1L +let one_minute = of_seconds_exn 60L +let one_hour = of_seconds_exn 3600L diff --git a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli new file mode 100644 index 000000000..555b704df --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli @@ -0,0 +1,46 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t +type period = t +include Compare.S with type t := t +val encoding : period Data_encoding.t +val pp: Format.formatter -> period -> unit + + +val to_seconds : period -> int64 + +(** [of_second period] fails if period is not positive *) +val of_seconds : int64 -> period tzresult + +(** [of_second period] fails if period is not positive. + It should only be used at toplevel for constants. *) +val of_seconds_exn : int64 -> period + +val mult : int32 -> period -> period tzresult + +val one_second : period +val one_minute : period +val one_hour : period diff --git a/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml new file mode 100644 index 000000000..02fc79723 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml @@ -0,0 +1,313 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type QTY = sig + val id : string +end + +module type S = sig + type qty + + type error += + | Addition_overflow of qty * qty (* `Temporary *) + | Subtraction_underflow of qty * qty (* `Temporary *) + | Multiplication_overflow of qty * int64 (* `Temporary *) + | Negative_multiplicator of qty * int64 (* `Temporary *) + | Invalid_divisor of qty * int64 (* `Temporary *) + + val id : string + val zero : qty + val one_mutez : qty + val one_cent : qty + val fifty_cents : qty + val one : qty + + val ( -? ) : qty -> qty -> qty tzresult + val ( +? ) : qty -> qty -> qty tzresult + val ( *? ) : qty -> int64 -> qty tzresult + val ( /? ) : qty -> int64 -> qty tzresult + + val to_mutez : qty -> int64 + + (** [of_mutez n] (micro tez) is None if n is negative *) + val of_mutez : int64 -> qty option + + (** [of_mutez_exn n] fails if n is negative. + It should only be used at toplevel for constants. *) + val of_mutez_exn : int64 -> qty + + (** It should only be used at toplevel for constants. *) + val add_exn : qty -> qty -> qty + + (** It should only be used at toplevel for constants. *) + val mul_exn : qty -> int -> qty + + val encoding : qty Data_encoding.t + + val to_int64 : qty -> int64 + + include Compare.S with type t := qty + + val pp: Format.formatter -> qty -> unit + + val of_string: string -> qty option + val to_string: qty -> string + +end + +module Make (T: QTY) : S = struct + + type qty = int64 (* invariant: positive *) + + type error += + | Addition_overflow of qty * qty (* `Temporary *) + | Subtraction_underflow of qty * qty (* `Temporary *) + | Multiplication_overflow of qty * int64 (* `Temporary *) + | Negative_multiplicator of qty * int64 (* `Temporary *) + | Invalid_divisor of qty * int64 (* `Temporary *) + + include Compare.Int64 + let zero = 0L + (* all other constant are defined from the value of one micro tez *) + let one_mutez = 1L + let one_cent = Int64.mul one_mutez 10_000L + let fifty_cents = Int64.mul one_cent 50L + (* 1 tez = 100 cents = 1_000_000 mutez *) + let one = Int64.mul one_cent 100L + let id = T.id + + let of_string s = + let triplets = function + | hd :: tl -> + let len = String.length hd in + Compare.Int.( + len <= 3 && len > 0 && + List.for_all (fun s -> String.length s = 3) tl + ) + | [] -> false in + let integers s = triplets (String.split_on_char ',' s) in + let decimals s = + let l = String.split_on_char ',' s in + if Compare.Int.(List.length l > 2) then + false + else + triplets (List.rev l) in + let parse left right = + let remove_commas s = String.concat "" (String.split_on_char ',' s) in + let pad_to_six s = + let len = String.length s in + String.init 6 (fun i -> if Compare.Int.(i < len) then String.get s i else '0') in + try + Some (Int64.of_string (remove_commas left ^ pad_to_six (remove_commas right))) + with _ -> None in + match String.split_on_char '.' s with + | [ left ; right ] -> + if String.contains s ',' then + if integers left && decimals right then + parse left right + else + None + else if Compare.Int.(String.length right > 0) + && Compare.Int.(String.length right <= 6) then + parse left right + else None + | [ left ] -> + if not (String.contains s ',') || integers left then + parse left "" + else None + | _ -> None + + let pp ppf amount = + let mult_int = 1_000_000L in + let rec left ppf amount = + let d, r = Int64.(div amount 1000L), Int64.(rem amount 1000L) in + if d > 0L then + Format.fprintf ppf "%a%03Ld" left d r + else + Format.fprintf ppf "%Ld" r in + let right ppf amount = + let triplet ppf v = + if Compare.Int.(v mod 10 > 0) then + Format.fprintf ppf "%03d" v + else if Compare.Int.(v mod 100 > 0) then + Format.fprintf ppf "%02d" (v / 10) + else + Format.fprintf ppf "%d" (v / 100) in + let hi, lo = amount / 1000, amount mod 1000 in + if Compare.Int.(lo = 0) then + Format.fprintf ppf "%a" triplet hi + else + Format.fprintf ppf "%03d%a" hi triplet lo in + let ints, decs = + Int64.(div amount mult_int), + Int64.(to_int (rem amount mult_int)) in + Format.fprintf ppf "%a" left ints ; + if Compare.Int.(decs > 0) then + Format.fprintf ppf ".%a" right decs + + let to_string t = + Format.asprintf "%a" pp t + + let (-) t1 t2 = + if t2 <= t1 + then Some (Int64.sub t1 t2) + else None + + let ( -? ) t1 t2 = + match t1 - t2 with + | None -> error (Subtraction_underflow (t1, t2)) + | Some v -> ok v + + let ( +? ) t1 t2 = + let t = Int64.add t1 t2 in + if t < t1 + then error (Addition_overflow (t1, t2)) + else ok t + + let ( *? ) t m = + let open Compare.Int64 in + let open Int64 in + let rec step cur pow acc = + if cur = 0L then + ok acc + else + pow +? pow >>? fun npow -> + if logand cur 1L = 1L then + acc +? pow >>? fun nacc -> + step (shift_right_logical cur 1) npow nacc + else + step (shift_right_logical cur 1) npow acc in + if m < 0L then + error (Negative_multiplicator (t, m)) + else + match step m t 0L with + | Ok res -> Ok res + | Error ([ Addition_overflow _ ] as errs) -> + Error (Multiplication_overflow (t, m) :: errs) + | Error errs -> Error errs + + let ( /? ) t d = + if d <= 0L then + error (Invalid_divisor (t, d)) + else + ok (Int64.div t d) + + let add_exn t1 t2 = + let t = Int64.add t1 t2 in + if t <= 0L + then invalid_arg "add_exn" + else t + + let mul_exn t m = + match t *? Int64.(of_int m) with + | Ok v -> v + | Error _ -> invalid_arg "mul_exn" + + let of_mutez t = + if t < 0L then None + else Some t + + let of_mutez_exn x = + match of_mutez x with + | None -> invalid_arg "Qty.of_mutez" + | Some v -> v + + let to_int64 t = t + let to_mutez t = t + + let encoding = + let open Data_encoding in + (check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)) + + let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:(T.id ^ ".addition_overflow") + ~title:("Overflowing " ^ T.id ^ " addition") + ~pp: (fun ppf (opa, opb) -> + Format.fprintf ppf "Overflowing addition of %a %s and %a %s" + pp opa T.id pp opb T.id) + ~description: + ("An addition of two " ^ T.id ^ " amounts overflowed") + (obj1 (req "amounts" (tup2 encoding encoding))) + (function Addition_overflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Addition_overflow (a, b)) ; + register_error_kind + `Temporary + ~id:(T.id ^ ".subtraction_underflow") + ~title:("Underflowing " ^ T.id ^ " subtraction") + ~pp: (fun ppf (opa, opb) -> + Format.fprintf ppf "Underflowing subtraction of %a %s and %a %s" + pp opa T.id pp opb T.id) + ~description: + ("An subtraction of two " ^ T.id ^ " amounts underflowed") + (obj1 (req "amounts" (tup2 encoding encoding))) + (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Subtraction_underflow (a, b)) ; + register_error_kind + `Temporary + ~id:(T.id ^ ".multiplication_overflow") + ~title:("Overflowing " ^ T.id ^ " multiplication") + ~pp: (fun ppf (opa, opb) -> + Format.fprintf ppf "Overflowing multiplication of %a %s and %Ld" + pp opa T.id opb) + ~description: + ("A multiplication of a " ^ T.id ^ " amount by an integer overflowed") + (obj2 + (req "amount" encoding) + (req "multiplicator" int64)) + (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Multiplication_overflow (a, b)) ; + register_error_kind + `Temporary + ~id:(T.id ^ ".negative_multiplicator") + ~title:("Negative " ^ T.id ^ " multiplicator") + ~pp: (fun ppf (opa, opb) -> + Format.fprintf ppf "Multiplication of %a %s by negative integer %Ld" + pp opa T.id opb) + ~description: + ("Multiplication of a " ^ T.id ^ " amount by a negative integer") + (obj2 + (req "amount" encoding) + (req "multiplicator" int64)) + (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Negative_multiplicator (a, b)) ; + register_error_kind + `Temporary + ~id:(T.id ^ ".invalid_divisor") + ~title:("Invalid " ^ T.id ^ " divisor") + ~pp: (fun ppf (opa, opb) -> + Format.fprintf ppf "Division of %a %s by non positive integer %Ld" + pp opa T.id opb) + ~description: + ("Multiplication of a " ^ T.id ^ " amount by a non positive integer") + (obj2 + (req "amount" encoding) + (req "divisor" int64)) + (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Invalid_divisor (a, b)) + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml new file mode 100644 index 000000000..e1eb7386b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml @@ -0,0 +1,652 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Int_set = Set.Make (Compare.Int) + +type t = { + context: Context.t ; + constants: Constants_repr.parametric ; + first_level: Raw_level_repr.t ; + level: Level_repr.t ; + timestamp: Time.t ; + fitness: Int64.t ; + deposits: Tez_repr.t Signature.Public_key_hash.Map.t ; + allowed_endorsements: + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ; + fees: Tez_repr.t ; + rewards: Tez_repr.t ; + block_gas: Z.t ; + operation_gas: Gas_limit_repr.t ; + storage_space_to_pay: Z.t option ; + allocated_contracts: int option ; + origination_nonce: Contract_repr.origination_nonce option ; + internal_nonce: int ; + internal_nonces_used: Int_set.t ; +} + +type context = t +type root_context = t + +let current_level ctxt = ctxt.level +let current_timestamp ctxt = ctxt.timestamp +let current_fitness ctxt = ctxt.fitness +let first_level ctxt = ctxt.first_level +let constants ctxt = ctxt.constants +let recover ctxt = ctxt.context + +let record_endorsement ctxt k = + match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with + | None -> assert false + | Some (_, _, true) -> assert false (* right already used *) + | Some (d, s, false) -> + { ctxt with + allowed_endorsements = + Signature.Public_key_hash.Map.add k (d,s,true) ctxt.allowed_endorsements } + +let init_endorsements ctxt allowed_endorsements = + if Signature.Public_key_hash.Map.is_empty allowed_endorsements + then assert false (* can't initialize to empty *) + else begin + if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements + then { ctxt with allowed_endorsements } + else assert false (* can't initialize twice *) + end + +let allowed_endorsements ctxt = + ctxt.allowed_endorsements + +type error += Too_many_internal_operations (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"too_many_internal_operations" + ~title: "Too many internal operations" + ~description: + "A transaction exceeded the hard limit \ + of internal operations it can emit" + empty + (function Too_many_internal_operations -> Some () | _ -> None) + (fun () -> Too_many_internal_operations) + +let fresh_internal_nonce ctxt = + if Compare.Int.(ctxt.internal_nonce >= 65_535) then + error Too_many_internal_operations + else + ok ({ ctxt with internal_nonce = ctxt.internal_nonce + 1 }, ctxt.internal_nonce) +let reset_internal_nonce ctxt = + { ctxt with internal_nonces_used = Int_set.empty ; internal_nonce = 0 } +let record_internal_nonce ctxt k = + { ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used } +let internal_nonce_already_recorded ctxt k = + Int_set.mem k ctxt.internal_nonces_used + +let set_current_fitness ctxt fitness = { ctxt with fitness } + +let add_fees ctxt fees = + Lwt.return Tez_repr.(ctxt.fees +? fees) >>=? fun fees -> + return { ctxt with fees} + +let add_rewards ctxt rewards = + Lwt.return Tez_repr.(ctxt.rewards +? rewards) >>=? fun rewards -> + return { ctxt with rewards} + +let add_deposit ctxt delegate deposit = + let previous = + match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with + | Some tz -> tz + | None -> Tez_repr.zero in + Lwt.return Tez_repr.(previous +? deposit) >>=? fun deposit -> + let deposits = + Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits in + return { ctxt with deposits } + +let get_deposits ctxt = ctxt.deposits +let get_rewards ctxt = ctxt.rewards +let get_fees ctxt = ctxt.fees + +type error += Undefined_operation_nonce (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"undefined_operation_nonce" + ~title: "Ill timed access to the origination nonce" + ~description: + "An origination was attemped out of the scope of a manager operation" + empty + (function Undefined_operation_nonce -> Some () | _ -> None) + (fun () -> Undefined_operation_nonce) + +let init_origination_nonce ctxt operation_hash = + let origination_nonce = + Some (Contract_repr.initial_origination_nonce operation_hash) in + { ctxt with origination_nonce } + +let origination_nonce ctxt = + match ctxt.origination_nonce with + | None -> error Undefined_operation_nonce + | Some origination_nonce -> ok origination_nonce + +let increment_origination_nonce ctxt = + match ctxt.origination_nonce with + | None -> error Undefined_operation_nonce + | Some cur_origination_nonce -> + let origination_nonce = + Some (Contract_repr.incr_origination_nonce cur_origination_nonce) in + ok ({ ctxt with origination_nonce }, cur_origination_nonce) + +let unset_origination_nonce ctxt = + { ctxt with origination_nonce = None } + +type error += Gas_limit_too_high (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"gas_limit_too_high" + ~title: "Gas limit out of protocol hard bounds" + ~description: + "A transaction tried to exceed the hard limit on gas" + empty + (function Gas_limit_too_high -> Some () | _ -> None) + (fun () -> Gas_limit_too_high) + +let check_gas_limit ctxt remaining = + if Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation) + || Compare.Z.(remaining < Z.zero) then + error Gas_limit_too_high + else + ok () +let set_gas_limit ctxt remaining = + { ctxt with operation_gas = Limited { remaining } } +let set_gas_unlimited ctxt = + { ctxt with operation_gas = Unaccounted } +let consume_gas ctxt cost = + Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) -> + ok { ctxt with block_gas ; operation_gas } +let check_enough_gas ctxt cost = + Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost +let gas_level ctxt = ctxt.operation_gas +let block_gas_level ctxt = ctxt.block_gas +let gas_consumed ~since ~until = + match gas_level since, gas_level until with + | Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after + | _, _ -> Z.zero + +let init_storage_space_to_pay ctxt = + match ctxt.storage_space_to_pay with + | Some _ -> + assert false + | None -> + { ctxt with storage_space_to_pay = Some Z.zero ; allocated_contracts = Some 0 } + +let update_storage_space_to_pay ctxt n = + match ctxt.storage_space_to_pay with + | None -> + assert false + | Some storage_space_to_pay -> + { ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay) } + +let update_allocated_contracts_count ctxt = + match ctxt.allocated_contracts with + | None -> + assert false + | Some allocated_contracts -> + { ctxt with allocated_contracts = Some (succ allocated_contracts) } + +let clear_storage_space_to_pay ctxt = + match ctxt.storage_space_to_pay, ctxt.allocated_contracts with + | None, _ | _, None -> + assert false + | Some storage_space_to_pay, Some allocated_contracts -> + { ctxt with storage_space_to_pay = None ; + allocated_contracts = None}, + storage_space_to_pay, + allocated_contracts + +type storage_error = + | Incompatible_protocol_version of string + | Missing_key of string list * [`Get | `Set | `Del | `Copy] + | Existing_key of string list + | Corrupted_data of string list + +let storage_error_encoding = + let open Data_encoding in + union [ + case (Tag 0) + ~title:"Incompatible_protocol_version" + (obj1 (req "incompatible_protocol_version" string)) + (function Incompatible_protocol_version arg -> Some arg | _ -> None) + (fun arg -> Incompatible_protocol_version arg) ; + case (Tag 1) + ~title:"Missing_key" + (obj2 + (req "missing_key" (list string)) + (req "function" (string_enum ["get", `Get ; "set", `Set ; "del", `Del ; "copy", `Copy ]))) + (function Missing_key (key, f) -> Some (key, f) | _ -> None) + (fun (key, f) -> Missing_key (key, f)) ; + case (Tag 2) + ~title:"Existing_key" + (obj1 (req "existing_key" (list string))) + (function Existing_key key -> Some key | _ -> None) + (fun key -> Existing_key key) ; + case (Tag 3) + ~title:"Corrupted_data" + (obj1 (req "corrupted_data" (list string))) + (function Corrupted_data key -> Some key | _ -> None) + (fun key -> Corrupted_data key) ; + ] + +let pp_storage_error ppf = function + | Incompatible_protocol_version version -> + Format.fprintf ppf + "Found a context with an unexpected version '%s'." + version + | Missing_key (key, `Get) -> + Format.fprintf ppf + "Missing key '%s'." + (String.concat "/" key) + | Missing_key (key, `Set) -> + Format.fprintf ppf + "Cannot set undefined key '%s'." + (String.concat "/" key) + | Missing_key (key, `Del) -> + Format.fprintf ppf + "Cannot delete undefined key '%s'." + (String.concat "/" key) + | Missing_key (key, `Copy) -> + Format.fprintf ppf + "Cannot copy undefined key '%s'." + (String.concat "/" key) + | Existing_key key -> + Format.fprintf ppf + "Cannot initialize defined key '%s'." + (String.concat "/" key) + | Corrupted_data key -> + Format.fprintf ppf + "Failed to parse the data at '%s'." + (String.concat "/" key) + +type error += Storage_error of storage_error + +let () = + register_error_kind + `Permanent + ~id:"context.storage_error" + ~title: "Storage error (fatal internal error)" + ~description: + "An error that should never happen unless something \ + has been deleted or corrupted in the database." + ~pp:(fun ppf err -> + Format.fprintf ppf + "@[Storage error:@ %a@]" + pp_storage_error err) + storage_error_encoding + (function Storage_error err -> Some err | _ -> None) + (fun err -> Storage_error err) + +let storage_error err = fail (Storage_error err) + +(* Initialization *********************************************************) + +(* This key should always be populated for every version of the + protocol. It's absence meaning that the context is empty. *) +let version_key = ["version"] +let version_value = "alpha_current" + +let version = "v1" +let first_level_key = [ version ; "first_level" ] +let constants_key = [ version ; "constants" ] +let protocol_param_key = [ "protocol_parameters" ] + +let get_first_level ctxt = + Context.get ctxt first_level_key >>= function + | None -> storage_error (Missing_key (first_level_key, `Get)) + | Some bytes -> + match + Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes + with + | None -> storage_error (Corrupted_data first_level_key) + | Some level -> return level + +let set_first_level ctxt level = + let bytes = + Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level in + Context.set ctxt first_level_key bytes >>= fun ctxt -> + return ctxt + +type error += Failed_to_parse_parameter of MBytes.t +type error += Failed_to_decode_parameter of Data_encoding.json * string + +let () = + register_error_kind + `Temporary + ~id:"context.failed_to_parse_parameter" + ~title: "Failed to parse parameter" + ~description: + "The protocol parameters are not valid JSON." + ~pp:begin fun ppf bytes -> + Format.fprintf ppf + "@[Cannot parse the protocol parameter:@ %s@]" + (MBytes.to_string bytes) + end + Data_encoding.(obj1 (req "contents" bytes)) + (function Failed_to_parse_parameter data -> Some data | _ -> None) + (fun data -> Failed_to_parse_parameter data) ; + register_error_kind + `Temporary + ~id:"context.failed_to_decode_parameter" + ~title: "Failed to decode parameter" + ~description: + "Unexpected JSON object." + ~pp:begin fun ppf (json, msg) -> + Format.fprintf ppf + "@[Cannot decode the protocol parameter:@ %s@ %a@]" + msg + Data_encoding.Json.pp json + end + Data_encoding.(obj2 + (req "contents" json) + (req "error" string)) + (function + | Failed_to_decode_parameter (json, msg) -> Some (json, msg) + | _ -> None) + (fun (json, msg) -> Failed_to_decode_parameter (json, msg)) + +let get_proto_param ctxt = + Context.get ctxt protocol_param_key >>= function + | None -> + failwith "Missing protocol parameters." + | Some bytes -> + match Data_encoding.Binary.of_bytes Data_encoding.json bytes with + | None -> fail (Failed_to_parse_parameter bytes) + | Some json -> begin + Context.del ctxt protocol_param_key >>= fun ctxt -> + match Data_encoding.Json.destruct Parameters_repr.encoding json with + | exception (Data_encoding.Json.Cannot_destruct _ as exn) -> + Format.kasprintf + failwith "Invalid protocol_parameters: %a %a" + (fun ppf -> Data_encoding.Json.print_error ppf) exn + Data_encoding.Json.pp json + | param -> return (param, ctxt) + end + +let set_constants ctxt constants = + let bytes = + Data_encoding.Binary.to_bytes_exn + Parameters_repr.constants_encoding constants in + Context.set ctxt constants_key bytes + +let get_constants ctxt = + Context.get ctxt constants_key >>= function + | None -> + failwith "Internal error: cannot read constants in context." + | Some bytes -> + match + Data_encoding.Binary.of_bytes Parameters_repr.constants_encoding bytes + with + | None -> + failwith "Internal error: cannot parse constants in context." + | Some constants -> return constants + +let patch_constants ctxt f = + let constants = f ctxt.constants in + set_constants ctxt.context constants >>= fun context -> + Lwt.return { ctxt with context ; constants } + +let check_inited ctxt = + Context.get ctxt version_key >>= function + | None -> + failwith "Internal error: un-initialized context." + | Some bytes -> + let s = MBytes.to_string bytes in + if Compare.String.(s = version_value) then + return_unit + else + storage_error (Incompatible_protocol_version s) + +let prepare ~level ~timestamp ~fitness ctxt = + Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level -> + Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> + check_inited ctxt >>=? fun () -> + get_constants ctxt >>=? fun constants -> + get_first_level ctxt >>=? fun first_level -> + let level = + Level_repr.from_raw + ~first_level + ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle + ~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period + ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment + level in + return { + context = ctxt ; constants ; level ; + timestamp ; fitness ; first_level ; + allowed_endorsements = Signature.Public_key_hash.Map.empty ; + fees = Tez_repr.zero ; + rewards = Tez_repr.zero ; + deposits = Signature.Public_key_hash.Map.empty ; + operation_gas = Unaccounted ; + storage_space_to_pay = None ; + allocated_contracts = None ; + block_gas = constants.Constants_repr.hard_gas_limit_per_block ; + origination_nonce = None ; + internal_nonce = 0 ; + internal_nonces_used = Int_set.empty ; + } + +type previous_protocol = + | Genesis of Parameters_repr.t + | Alpha_previous + +let check_and_update_protocol_version ctxt = + begin + Context.get ctxt version_key >>= function + | None -> + failwith "Internal error: un-initialized context in check_first_block." + | Some bytes -> + let s = MBytes.to_string bytes in + if Compare.String.(s = version_value) then + failwith "Internal error: previously initialized context." + else if Compare.String.(s = "genesis") then + get_proto_param ctxt >>=? fun (param, ctxt) -> + return (Genesis param, ctxt) + else if Compare.String.(s = "alpha_previous") then + return (Alpha_previous, ctxt) + else + storage_error (Incompatible_protocol_version s) + end >>=? fun (previous_proto, ctxt) -> + Context.set ctxt version_key + (MBytes.of_string version_value) >>= fun ctxt -> + return (previous_proto, ctxt) + +let prepare_first_block ~level ~timestamp ~fitness ctxt = + check_and_update_protocol_version ctxt >>=? fun (previous_proto, ctxt) -> + begin + match previous_proto with + | Genesis param -> + Lwt.return (Raw_level_repr.of_int32 level) >>=? fun first_level -> + set_first_level ctxt first_level >>=? fun ctxt -> + set_constants ctxt param.constants >>= fun ctxt -> + return ctxt + | Alpha_previous -> + return ctxt + end >>=? fun ctxt -> + prepare ctxt ~level ~timestamp ~fitness >>=? fun ctxt -> + return (previous_proto, ctxt) + +let activate ({ context = c ; _ } as s) h = + Updater.activate c h >>= fun c -> Lwt.return { s with context = c } + +let fork_test_chain ({ context = c ; _ } as s) protocol expiration = + Updater.fork_test_chain c ~protocol ~expiration >>= fun c -> + Lwt.return { s with context = c } + +let register_resolvers enc resolve = + let resolve context str = + let faked_context = { + context ; + constants = Constants_repr.default ; + first_level = Raw_level_repr.root ; + level = Level_repr.root Raw_level_repr.root ; + timestamp = Time.of_seconds 0L ; + fitness = 0L ; + allowed_endorsements = Signature.Public_key_hash.Map.empty ; + storage_space_to_pay = None ; + allocated_contracts = None ; + fees = Tez_repr.zero ; + rewards = Tez_repr.zero ; + deposits = Signature.Public_key_hash.Map.empty ; + block_gas = Constants_repr.default.hard_gas_limit_per_block ; + operation_gas = Unaccounted ; + origination_nonce = None ; + internal_nonce = 0 ; + internal_nonces_used = Int_set.empty ; + } in + resolve faked_context str in + Context.register_resolver enc resolve + +(* Generic context ********************************************************) + +type key = string list + +type value = MBytes.t + +module type T = sig + + type t + type context = t + + val mem: context -> key -> bool Lwt.t + val dir_mem: context -> key -> bool Lwt.t + val get: context -> key -> value tzresult Lwt.t + val get_option: context -> key -> value option Lwt.t + val init: context -> key -> value -> context tzresult Lwt.t + val set: context -> key -> value -> context tzresult Lwt.t + val init_set: context -> key -> value -> context Lwt.t + val set_option: context -> key -> value option -> context Lwt.t + val delete: context -> key -> context tzresult Lwt.t + val remove: context -> key -> context Lwt.t + val remove_rec: context -> key -> context Lwt.t + val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + + val fold: + context -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + val keys: context -> key -> key list Lwt.t + + val fold_keys: + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val project: context -> root_context + + val absolute_key: context -> key -> key + + val consume_gas: context -> Gas_limit_repr.cost -> context tzresult + + val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult + + val description: context Storage_description.t + +end + +let mem ctxt k = Context.mem ctxt.context k +let dir_mem ctxt k = Context.dir_mem ctxt.context k + +let get ctxt k = + Context.get ctxt.context k >>= function + | None -> storage_error (Missing_key (k, `Get)) + | Some v -> return v + +let get_option ctxt k = + Context.get ctxt.context k + +(* Verify that the k is present before modifying *) +let set ctxt k v = + Context.mem ctxt.context k >>= function + | false -> storage_error (Missing_key (k, `Set)) + | true -> + Context.set ctxt.context k v >>= fun context -> + return { ctxt with context } + +(* Verify that the k is not present before inserting *) +let init ctxt k v = + Context.mem ctxt.context k >>= function + | true -> storage_error (Existing_key k) + | false -> + Context.set ctxt.context k v >>= fun context -> + return { ctxt with context } + +(* Does not verify that the key is present or not *) +let init_set ctxt k v = + Context.set ctxt.context k v >>= fun context -> + Lwt.return { ctxt with context } + +(* Verify that the key is present before deleting *) +let delete ctxt k = + Context.mem ctxt.context k >>= function + | false -> storage_error (Missing_key (k, `Del)) + | true -> + Context.del ctxt.context k >>= fun context -> + return { ctxt with context } + +(* Do not verify before deleting *) +let remove ctxt k = + Context.del ctxt.context k >>= fun context -> + Lwt.return { ctxt with context } + +let set_option ctxt k = function + | None -> remove ctxt k + | Some v -> init_set ctxt k v + +let remove_rec ctxt k = + Context.remove_rec ctxt.context k >>= fun context -> + Lwt.return { ctxt with context } + +let copy ctxt ~from ~to_ = + Context.copy ctxt.context ~from ~to_ >>= function + | None -> storage_error (Missing_key (from, `Copy)) + | Some context -> + return { ctxt with context } + +let fold ctxt k ~init ~f = + Context.fold ctxt.context k ~init ~f + +let keys ctxt k = + Context.keys ctxt.context k + +let fold_keys ctxt k ~init ~f = + Context.fold_keys ctxt.context k ~init ~f + +let project x = x + +let absolute_key _ k = k + +let description = Storage_description.create () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli new file mode 100644 index 000000000..2dfc0ca3d --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli @@ -0,0 +1,253 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 Errors} ****************************************************************) + +type error += Too_many_internal_operations (* `Permanent *) + +(** An internal storage error that should not happen *) +type storage_error = + | Incompatible_protocol_version of string + | Missing_key of string list * [`Get | `Set | `Del | `Copy] + | Existing_key of string list + | Corrupted_data of string list + +type error += Storage_error of storage_error +type error += Failed_to_parse_parameter of MBytes.t +type error += Failed_to_decode_parameter of Data_encoding.json * string + +val storage_error: storage_error -> 'a tzresult Lwt.t + +(** {1 Abstract Context} **************************************************) + +(** Abstract view of the context. + Includes a handle to the functional key-value database + ({!Context.t}) along with some in-memory values (gas, etc.). *) +type t +type context = t +type root_context = t + +(** Retrieves the state of the database and gives its abstract view. + It also returns wether this is the first block validated + with this version of the protocol. *) +val prepare: + level: Int32.t -> + timestamp: Time.t -> + fitness: Fitness.t -> + Context.t -> context tzresult Lwt.t + +type previous_protocol = + | Genesis of Parameters_repr.t + | Alpha_previous + +val prepare_first_block: + level:int32 -> + timestamp:Time.t -> + fitness:Fitness.t -> + Context.t -> (previous_protocol * context) tzresult Lwt.t + +val activate: context -> Protocol_hash.t -> t Lwt.t +val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t + +val register_resolvers: + 'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit + +(** Returns the state of the database resulting of operations on its + abstract view *) +val recover: context -> Context.t + +val current_level: context -> Level_repr.t +val current_timestamp: context -> Time.t + +val current_fitness: context -> Int64.t +val set_current_fitness: context -> Int64.t -> t + +val constants: context -> Constants_repr.parametric +val patch_constants: + context -> + (Constants_repr.parametric -> Constants_repr.parametric) -> + context Lwt.t +val first_level: context -> Raw_level_repr.t + +(** Increment the current block fee stash that will be credited to baker's + frozen_fees account at finalize_application *) +val add_fees: context -> Tez_repr.t -> context tzresult Lwt.t + +(** Increment the current block reward stash that will be credited to baker's + frozen_fees account at finalize_application *) +val add_rewards: context -> Tez_repr.t -> context tzresult Lwt.t + +(** Increment the current block deposit stash for a specific delegate. All the + delegates' frozen_deposit accounts are credited at finalize_application *) +val add_deposit: + context -> Signature.Public_key_hash.t -> Tez_repr.t -> context tzresult Lwt.t + +val get_fees: context -> Tez_repr.t +val get_rewards: context -> Tez_repr.t +val get_deposits: context -> Tez_repr.t Signature.Public_key_hash.Map.t + +type error += Gas_limit_too_high (* `Permanent *) + +val check_gas_limit: t -> Z.t -> unit tzresult +val set_gas_limit: t -> Z.t -> t +val set_gas_unlimited: t -> t +val gas_level: t -> Gas_limit_repr.t +val gas_consumed: since: t -> until: t -> Z.t +val block_gas_level: t -> Z.t + +val init_storage_space_to_pay: t -> t +val update_storage_space_to_pay: t -> Z.t -> t +val update_allocated_contracts_count: t -> t +val clear_storage_space_to_pay: t -> t * Z.t * int + +type error += Undefined_operation_nonce (* `Permanent *) + +val init_origination_nonce: t -> Operation_hash.t -> t +val origination_nonce: t -> Contract_repr.origination_nonce tzresult +val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult +val unset_origination_nonce: t -> t + +(** {1 Generic accessors} *************************************************) + +type key = string list + +type value = MBytes.t + +(** All context manipulation functions. This signature is included + as-is for direct context accesses, and used in {!Storage_functors} + to provide restricted views to the context. *) +module type T = sig + + type t + type context = t + + (** Tells if the key is already defined as a value. *) + val mem: context -> key -> bool Lwt.t + + (** Tells if the key is already defined as a directory. *) + val dir_mem: context -> key -> bool Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error Missing_key} if the key is not set. *) + val get: context -> key -> value tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized. *) + val get_option: context -> key -> value option Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Existing_key} if the bucket exists. *) + val init: context -> key -> value -> context tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_error + Missing_key} if the value does not exists. *) + val set: context -> key -> value -> context tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists. *) + val init_set: context -> key -> value -> context Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option: context -> key -> value option -> context Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists. *) + val delete: context -> key -> context tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if the + bucket does not exists. *) + val remove: context -> key -> context Lwt.t + + (** Recursively removes all the storage buckets and contents ; does + nothing if no bucket exists. *) + val remove_rec: context -> key -> context Lwt.t + + val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + + (** Iterator on all the items of a given directory. *) + val fold: + context -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + (** Recursively list all subkeys of a given key. *) + val keys: context -> key -> key list Lwt.t + + (** Recursive iterator on all the subkeys of a given key. *) + val fold_keys: + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Internally used in {!Storage_functors} to escape from a view. *) + val project: context -> root_context + + (** Internally used in {!Storage_functors} to retrieve a full key + from partial key relative a view. *) + val absolute_key: context -> key -> key + + (** Internally used in {!Storage_functors} to consume gas from + within a view. *) + val consume_gas: context -> Gas_limit_repr.cost -> context tzresult + + (** Check if consume_gas will fail *) + val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult + + val description: context Storage_description.t + +end + +include T with type t := t and type context := context + +(** Initialize the local nonce used for preventing a script to + duplicate an internal operation to replay it. *) +val reset_internal_nonce: context -> context + +(** Increments the internal operation nonce. *) +val fresh_internal_nonce: context -> (context * int) tzresult + +(** Mark an internal operation nonce as taken. *) +val record_internal_nonce: context -> int -> context + +(** Check is the internal operation nonce has been taken. *) +val internal_nonce_already_recorded: context -> int -> bool + +(** Returns a map where to each endorser's pkh is associated the list of its + endorsing slots (in decreasing order) for a given level. *) +val allowed_endorsements: + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t + +(** Initializes the map of allowed endorsements, this function must only be + called once. *) +val init_endorsements: + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> + context + +(** Marks an endorsment in the map as used. *) +val record_endorsement: + context -> Signature.Public_key_hash.t -> context diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml new file mode 100644 index 000000000..8af1b4543 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml @@ -0,0 +1,90 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = int32 +type raw_level = t +include (Compare.Int32 : Compare.S with type t := t) +let encoding = Data_encoding.int32 +let pp ppf level = Format.fprintf ppf "%ld" level +let rpc_arg = + let construct raw_level = Int32.to_string raw_level in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse level" + | raw_level -> Ok raw_level in + RPC_arg.make + ~descr:"A level integer" + ~name: "block_level" + ~construct + ~destruct + () + +let root = 0l +let succ = Int32.succ +let pred l = + if l = 0l + then None + else Some (Int32.pred l) + +let diff = Int32.sub + +let to_int32 l = l +let of_int32_exn l = + if Compare.Int32.(l >= 0l) + then l + else invalid_arg "Level_repr.of_int32" + +type error += Unexpected_level of Int32.t (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"unexpected_level" + ~title:"Unexpected level" + ~description:"Level must be non-negative." + ~pp:(fun ppf l -> + Format.fprintf ppf "The level is %s but should be non-negative." (Int32.to_string l)) + Data_encoding.(obj1 (req "level" int32)) + (function Unexpected_level l -> Some l | _ -> None) + (fun l -> Unexpected_level l) + +let of_int32 l = + try Ok (of_int32_exn l) + with _ -> Error [Unexpected_level l] + +module Index = struct + type t = raw_level + let path_length = 1 + let to_path level l = Int32.to_string level :: l + let of_path = function + | [s] -> begin + try Some (Int32.of_string s) + with _ -> None + end + | _ -> None + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli new file mode 100644 index 000000000..d7171dcf3 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The shell's notion of a level: an integer indicating the number of blocks + since genesis: genesis is 0, all other blocks have increasing levels from + there. *) +type t +type raw_level = t +val encoding: raw_level Data_encoding.t +val rpc_arg: raw_level RPC_arg.arg +val pp: Format.formatter -> raw_level -> unit +include Compare.S with type t := raw_level + +val to_int32: raw_level -> int32 +val of_int32_exn: int32 -> raw_level +val of_int32: int32 -> raw_level tzresult + +val diff: raw_level -> raw_level -> int32 + +val root: raw_level + +val succ: raw_level -> raw_level +val pred: raw_level -> raw_level option + +module Index : Storage_description.INDEX with type t = raw_level diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml new file mode 100644 index 000000000..65e3d8e73 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Compare.Int32 +type roll = t + +let encoding = Data_encoding.int32 + +let first = 0l +let succ i = Int32.succ i + +let random sequence ~bound = + Seed_repr.take_int32 sequence bound + +let rpc_arg = + RPC_arg.like + RPC_arg.int32 + "roll" + +let to_int32 v = v + + +module Index = struct + type t = roll + let path_length = 3 + let to_path roll l = + (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff)) :: + (Int32.to_string @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)) :: + Int32.to_string roll :: l + let of_path = function + | _ :: _ :: s :: _ -> begin + try Some (Int32.of_string s) + with _ -> None + end + | _ -> None + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli new file mode 100644 index 000000000..000e1c7c4 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli @@ -0,0 +1,42 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = private int32 +type roll = t + +val encoding: roll Data_encoding.t +val rpc_arg: roll RPC_arg.t + +val random: + Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence + +val first: roll +val succ: roll -> roll + +val to_int32: roll -> Int32.t + +val (=): roll -> roll -> bool + +module Index : Storage_description.INDEX with type t = roll diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml new file mode 100644 index 000000000..5c23075b0 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml @@ -0,0 +1,515 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Misc + +type error += + | Consume_roll_change (* `Permanent *) + | No_roll_for_delegate (* `Permanent *) + | No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *) + | Unregistered_delegate of Signature.Public_key_hash.t (* `Permanent *) + +let () = + let open Data_encoding in + (* Consume roll change *) + register_error_kind + `Permanent + ~id:"contract.manager.consume_roll_change" + ~title:"Consume roll change" + ~description:"Change is not enough to consume a roll." + ~pp:(fun ppf () -> + Format.fprintf ppf "Not enough change to consume a roll.") + empty + (function Consume_roll_change -> Some () | _ -> None) + (fun () -> Consume_roll_change) ; + (* No roll for delegate *) + register_error_kind + `Permanent + ~id:"contract.manager.no_roll_for_delegate" + ~title:"No roll for delegate" + ~description:"Delegate has no roll." + ~pp:(fun ppf () -> Format.fprintf ppf "Delegate has no roll.") + empty + (function No_roll_for_delegate -> Some () | _ -> None) + (fun () -> No_roll_for_delegate) ; + (* No roll snapshot for cycle *) + register_error_kind + `Permanent + ~id:"contract.manager.no_roll_snapshot_for_cycle" + ~title:"No roll snapshot for cycle" + ~description:"A snapshot of the rolls distribution does not exist for this cycle." + ~pp:(fun ppf c -> + Format.fprintf ppf + "A snapshot of the rolls distribution does not exist for cycle %a" Cycle_repr.pp c) + (obj1 (req "cycle" Cycle_repr.encoding)) + (function No_roll_snapshot_for_cycle c-> Some c | _ -> None) + (fun c -> No_roll_snapshot_for_cycle c) ; + (* Unregistered delegate *) + register_error_kind + `Permanent + ~id:"contract.manager.unregistered_delegate" + ~title:"Unregistered delegate" + ~description:"A contract cannot be delegated to an unregistered delegate" + ~pp:(fun ppf k-> + Format.fprintf ppf "The provided public key (with hash %a) is \ + \ not registered as valid delegate key." + Signature.Public_key_hash.pp k) + (obj1 (req "hash" Signature.Public_key_hash.encoding)) + (function Unregistered_delegate k -> Some k | _ -> None) + (fun k -> Unregistered_delegate k) + +let get_contract_delegate c contract = + Storage.Contract.Delegate.get_option c contract + +let delegate_pubkey ctxt delegate = + Storage.Contract.Manager.get_option ctxt + (Contract_repr.implicit_contract delegate) >>=? function + | None | Some (Manager_repr.Hash _) -> + fail (Unregistered_delegate delegate) + | Some (Manager_repr.Public_key pk) -> + return pk + +let clear_cycle c cycle = + Storage.Roll.Snapshot_for_cycle.get c cycle >>=? fun index -> + Storage.Roll.Snapshot_for_cycle.delete c cycle >>=? fun c -> + Storage.Roll.Last_for_snapshot.delete (c, cycle) index >>=? fun c -> + Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> + return c + +let fold ctxt ~f init = + Storage.Roll.Next.get ctxt >>=? fun last -> + let rec loop ctxt roll acc = + acc >>=? fun acc -> + if Roll_repr.(roll = last) then + return acc + else + Storage.Roll.Owner.get_option ctxt roll >>=? function + | None -> + loop ctxt (Roll_repr.succ roll) (return acc) + | Some delegate -> + loop ctxt (Roll_repr.succ roll) (f roll delegate acc) in + loop ctxt Roll_repr.first (return init) + +let snapshot_rolls_for_cycle ctxt cycle = + Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun index -> + Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1) >>=? fun ctxt -> + Storage.Roll.Owner.snapshot ctxt (cycle, index) >>=? fun ctxt -> + Storage.Roll.Next.get ctxt >>=? fun last -> + Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last >>=? fun ctxt -> + return ctxt + +let freeze_rolls_for_cycle ctxt cycle = + Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun max_index -> + Storage.Seed.For_cycle.get ctxt cycle >>=? fun seed -> + let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in + let seq = Seed_repr.sequence rd 0l in + let selected_index = + Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int in + Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index >>=? fun ctxt -> + fold_left_s + (fun ctxt index -> + if Compare.Int.(index = selected_index) then + return ctxt + else + Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) >>= fun ctxt -> + Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index >>=? fun ctxt -> + return ctxt + ) + ctxt + Misc.(0 --> (max_index - 1)) >>=? fun ctxt -> + return ctxt + +(* Roll selection *) + +module Random = struct + + let int32_to_bytes i = + let b = MBytes.create 4 in + MBytes.set_int32 b 0 i; + b + + let level_random seed use level = + let position = level.Level_repr.cycle_position in + Seed_repr.initialize_new seed + [MBytes.of_string ("level "^use^":"); + int32_to_bytes position] + + let owner c kind level offset = + let cycle = level.Level_repr.cycle in + Seed_storage.for_cycle c cycle >>=? fun random_seed -> + let rd = level_random random_seed kind level in + let sequence = Seed_repr.sequence rd (Int32.of_int offset) in + Storage.Roll.Snapshot_for_cycle.get c cycle >>=? fun index -> + Storage.Roll.Last_for_snapshot.get (c, cycle) index >>=? fun bound -> + let rec loop sequence = + let roll, sequence = Roll_repr.random sequence ~bound in + Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll) >>=? function + | None -> + loop sequence + | Some delegate -> + return delegate in + Storage.Roll.Owner.snapshot_exists c (cycle, index) >>= fun snapshot_exists -> + fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle) >>=? fun () -> + loop sequence + +end + +let baking_rights_owner c level ~priority = + Random.owner c "baking" level priority + +let endorsement_rights_owner c level ~slot = + Random.owner c "endorsement" level slot + +let traverse_rolls ctxt head = + let rec loop acc roll = + Storage.Roll.Successor.get_option ctxt roll >>=? function + | None -> return (List.rev acc) + | Some next -> loop (next :: acc) next in + loop [head] head + +let get_rolls ctxt delegate = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function + | None -> return_nil + | Some head_roll -> traverse_rolls ctxt head_roll + +let count_rolls ctxt delegate = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function + | None -> return 0 + | Some head_roll -> + let rec loop acc roll = + Storage.Roll.Successor.get_option ctxt roll >>=? function + | None -> return acc + | Some next -> loop (succ acc) next in + loop 1 head_roll + +let get_change c delegate = + Storage.Roll.Delegate_change.get_option c delegate >>=? function + | None -> return Tez_repr.zero + | Some change -> return change + +module Delegate = struct + + let fresh_roll c = + Storage.Roll.Next.get c >>=? fun roll -> + Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> + return (roll, c) + + let get_limbo_roll c = + Storage.Roll.Limbo.get_option c >>=? function + | None -> + fresh_roll c >>=? fun (roll, c) -> + Storage.Roll.Limbo.init c roll >>=? fun c -> + return (roll, c) + | Some roll -> + return (roll, c) + + let consume_roll_change c delegate = + let tokens_per_roll = Constants_storage.tokens_per_roll c in + Storage.Roll.Delegate_change.get c delegate >>=? fun change -> + trace Consume_roll_change + (Lwt.return Tez_repr.(change -? tokens_per_roll)) >>=? fun new_change -> + Storage.Roll.Delegate_change.set c delegate new_change + + let recover_roll_change c delegate = + let tokens_per_roll = Constants_storage.tokens_per_roll c in + Storage.Roll.Delegate_change.get c delegate >>=? fun change -> + Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun new_change -> + Storage.Roll.Delegate_change.set c delegate new_change + + let pop_roll_from_delegate c delegate = + recover_roll_change c delegate >>=? fun c -> + (* beginning: + delegate : roll -> successor_roll -> ... + limbo : limbo_head -> ... + *) + Storage.Roll.Limbo.get_option c >>=? fun limbo_head -> + Storage.Roll.Delegate_roll_list.get_option c delegate >>=? function + | None -> fail No_roll_for_delegate + | Some roll -> + Storage.Roll.Owner.delete c roll >>=? fun c -> + Storage.Roll.Successor.get_option c roll >>=? fun successor_roll -> + Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll >>= fun c -> + (* delegate : successor_roll -> ... + roll ------^ + limbo : limbo_head -> ... *) + Storage.Roll.Successor.set_option c roll limbo_head >>= fun c -> + (* delegate : successor_roll -> ... + roll ------v + limbo : limbo_head -> ... *) + Storage.Roll.Limbo.init_set c roll >>= fun c -> + (* delegate : successor_roll -> ... + limbo : roll -> limbo_head -> ... *) + return (roll, c) + + let create_roll_in_delegate c delegate delegate_pk = + consume_roll_change c delegate >>=? fun c -> + + (* beginning: + delegate : delegate_head -> ... + limbo : roll -> limbo_successor -> ... + *) + Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun delegate_head -> + get_limbo_roll c >>=? fun (roll, c) -> + Storage.Roll.Owner.init c roll delegate_pk >>=? fun c -> + Storage.Roll.Successor.get_option c roll >>=? fun limbo_successor -> + Storage.Roll.Limbo.set_option c limbo_successor >>= fun c -> + (* delegate : delegate_head -> ... + roll ------v + limbo : limbo_successor -> ... *) + Storage.Roll.Successor.set_option c roll delegate_head >>= fun c -> + (* delegate : delegate_head -> ... + roll ------^ + limbo : limbo_successor -> ... *) + Storage.Roll.Delegate_roll_list.init_set c delegate roll >>= fun c -> + (* delegate : roll -> delegate_head -> ... + limbo : limbo_successor -> ... *) + return c + + let ensure_inited c delegate = + Storage.Roll.Delegate_change.mem c delegate >>= function + | true -> return c + | false -> + Storage.Roll.Delegate_change.init c delegate Tez_repr.zero + + let is_inactive c delegate = + Storage.Contract.Inactive_delegate.mem c + (Contract_repr.implicit_contract delegate) >>= fun inactive -> + if inactive then + return inactive + else + Storage.Contract.Delegate_desactivation.get_option c + (Contract_repr.implicit_contract delegate) >>=? function + | Some last_active_cycle -> + let { Level_repr.cycle = current_cycle } = Raw_context.current_level c in + return Cycle_repr.(last_active_cycle < current_cycle) + | None -> + (* This case is only when called from `set_active`, when creating + a contract. *) + return_false + + let add_amount c delegate amount = + ensure_inited c delegate >>=? fun c -> + let tokens_per_roll = Constants_storage.tokens_per_roll c in + Storage.Roll.Delegate_change.get c delegate >>=? fun change -> + Lwt.return Tez_repr.(amount +? change) >>=? fun change -> + Storage.Roll.Delegate_change.set c delegate change >>=? fun c -> + delegate_pubkey c delegate >>=? fun delegate_pk -> + let rec loop c change = + if Tez_repr.(change < tokens_per_roll) then + return c + else + Lwt.return Tez_repr.(change -? tokens_per_roll) >>=? fun change -> + create_roll_in_delegate c delegate delegate_pk >>=? fun c -> + loop c change in + is_inactive c delegate >>=? fun inactive -> + if inactive then + return c + else + loop c change >>=? fun c -> + Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun rolls -> + match rolls with + | None -> + return c + | Some _ -> + Storage.Active_delegates_with_rolls.add c delegate >>= fun c -> + return c + + let remove_amount c delegate amount = + let tokens_per_roll = Constants_storage.tokens_per_roll c in + let rec loop c change = + if Tez_repr.(amount <= change) + then return (c, change) + else + pop_roll_from_delegate c delegate >>=? fun (_, c) -> + Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun change -> + loop c change in + Storage.Roll.Delegate_change.get c delegate >>=? fun change -> + is_inactive c delegate >>=? fun inactive -> + begin + if inactive then + return (c, change) + else + loop c change >>=? fun (c, change) -> + Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun rolls -> + match rolls with + | None -> + Storage.Active_delegates_with_rolls.del c delegate >>= fun c -> + return (c, change) + | Some _ -> + return (c, change) + end >>=? fun (c, change) -> + Lwt.return Tez_repr.(change -? amount) >>=? fun change -> + Storage.Roll.Delegate_change.set c delegate change + + let set_inactive ctxt delegate = + ensure_inited ctxt delegate >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate >>=? fun change -> + Storage.Contract.Inactive_delegate.add ctxt + (Contract_repr.implicit_contract delegate) >>= fun ctxt -> + Storage.Active_delegates_with_rolls.del ctxt delegate >>= fun ctxt -> + let rec loop ctxt change = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function + | None -> return (ctxt, change) + | Some _roll -> + pop_roll_from_delegate ctxt delegate >>=? fun (_, ctxt) -> + Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun change -> + loop ctxt change in + loop ctxt change >>=? fun (ctxt, change) -> + Storage.Roll.Delegate_change.set ctxt delegate change >>=? fun ctxt -> + return ctxt + + let set_active ctxt delegate = + is_inactive ctxt delegate >>=? fun inactive -> + let current_cycle = (Raw_context.current_level ctxt).cycle in + let preserved_cycles = Constants_storage.preserved_cycles ctxt in + (* When the delegate is new or inactive, she will become active in + `1+preserved_cycles`, and we allow `preserved_cycles` for the + delegate to start baking. When the delegate is active, we only + give her at least `preserved_cycles` after the current cycle + before to be deactivated. *) + Storage.Contract.Delegate_desactivation.get_option ctxt + (Contract_repr.implicit_contract delegate) >>=? fun current_expiration -> + let expiration = match current_expiration with + | None -> + Cycle_repr.add current_cycle (1+2*preserved_cycles) + | Some current_expiration -> + let delay = + if inactive then (1+2*preserved_cycles) else 1+preserved_cycles in + let updated = + Cycle_repr.add current_cycle delay in + Cycle_repr.max current_expiration updated in + Storage.Contract.Delegate_desactivation.init_set ctxt + (Contract_repr.implicit_contract delegate) + expiration >>= fun ctxt -> + if not inactive then + return ctxt + else begin + ensure_inited ctxt delegate >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate >>=? fun change -> + Storage.Contract.Inactive_delegate.del ctxt + (Contract_repr.implicit_contract delegate) >>= fun ctxt -> + delegate_pubkey ctxt delegate >>=? fun delegate_pk -> + let rec loop ctxt change = + if Tez_repr.(change < tokens_per_roll) then + return ctxt + else + Lwt.return Tez_repr.(change -? tokens_per_roll) >>=? fun change -> + create_roll_in_delegate ctxt delegate delegate_pk >>=? fun ctxt -> + loop ctxt change in + loop ctxt change >>=? fun ctxt -> + Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? fun rolls -> + match rolls with + | None -> + return ctxt + | Some _ -> + Storage.Active_delegates_with_rolls.add ctxt delegate >>= fun ctxt -> + return ctxt + end + +end + +module Contract = struct + + let add_amount c contract amount = + get_contract_delegate c contract >>=? function + | None -> return c + | Some delegate -> + Delegate.add_amount c delegate amount + + let remove_amount c contract amount = + get_contract_delegate c contract >>=? function + | None -> return c + | Some delegate -> + Delegate.remove_amount c delegate amount + +end + +let init ctxt = + Storage.Roll.Next.init ctxt Roll_repr.first + +let init_first_cycles ctxt = + let preserved = Constants_storage.preserved_cycles ctxt in + (* Precompute rolls for cycle (0 --> preserved_cycles) *) + List.fold_left + (fun ctxt c -> + ctxt >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt -> + snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt -> + freeze_rolls_for_cycle ctxt cycle) + (return ctxt) (0 --> preserved) >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in + (* Precomputed a snapshot for cycle (preserved_cycles + 1) *) + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt -> + snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt -> + (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *) + let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt -> + return ctxt + +let snapshot_rolls ctxt = + let current_level = Raw_context.current_level ctxt in + let preserved = Constants_storage.preserved_cycles ctxt in + let cycle = Cycle_repr.add current_level.cycle (preserved+2) in + snapshot_rolls_for_cycle ctxt cycle + +let cycle_end ctxt last_cycle = + let preserved = Constants_storage.preserved_cycles ctxt in + begin + match Cycle_repr.sub last_cycle preserved with + | None -> return ctxt + | Some cleared_cycle -> + clear_cycle ctxt cleared_cycle + end >>=? fun ctxt -> + let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved+1) in + freeze_rolls_for_cycle ctxt frozen_roll_cycle >>=? fun ctxt -> + Storage.Roll.Snapshot_for_cycle.init + ctxt (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0 >>=? fun ctxt -> + return ctxt + +let update_tokens_per_roll ctxt new_tokens_per_roll = + let constants = Raw_context.constants ctxt in + let old_tokens_per_roll = constants.tokens_per_roll in + Raw_context.patch_constants ctxt begin fun constants -> + { constants with Constants_repr.tokens_per_roll = new_tokens_per_roll } + end >>= fun ctxt -> + let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in + begin + if decrease then + Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll) + else + Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) + end >>=? fun abs_diff -> + Storage.Delegates.fold ctxt (Ok ctxt) begin fun pkh ctxt -> + Lwt.return ctxt >>=? fun ctxt -> + count_rolls ctxt pkh >>=? fun rolls -> + Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls) >>=? fun amount -> + if decrease then + Delegate.add_amount ctxt pkh amount + else + Delegate.remove_amount ctxt pkh amount + end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli new file mode 100644 index 000000000..5e901e72c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli @@ -0,0 +1,104 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + + Basic roll manipulation. + + If storage related to roll (a.k.a. `Storage.Roll`) are not used + outside of this module, this interface enforces the invariant that a + roll is always either in the limbo list or in a contract list. + +*) + +type error += + | Consume_roll_change + | No_roll_for_delegate + | No_roll_snapshot_for_cycle of Cycle_repr.t + | Unregistered_delegate of Signature.Public_key_hash.t (* `Permanent *) + +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t +val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t +val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t + + +val fold : + Raw_context.t -> + f:(Roll_repr.roll -> Signature.Public_key.t -> 'a -> 'a tzresult Lwt.t) -> + 'a -> 'a tzresult Lwt.t + +val baking_rights_owner : + Raw_context.t -> Level_repr.t -> priority:int -> + Signature.Public_key.t tzresult Lwt.t + +val endorsement_rights_owner : + Raw_context.t -> Level_repr.t -> slot:int -> + Signature.Public_key.t tzresult Lwt.t + +module Delegate : sig + + val is_inactive : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + + val add_amount : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + + val remove_amount : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + + val set_inactive : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t + + val set_active : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t + +end + +module Contract : sig + + val add_amount : + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + + val remove_amount : + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + +end + +val delegate_pubkey: + Raw_context.t -> Signature.Public_key_hash.t -> + Signature.Public_key.t tzresult Lwt.t + +val get_rolls: + Raw_context.t -> Signature.Public_key_hash.t -> Roll_repr.t list tzresult Lwt.t +val get_change: + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t + +val update_tokens_per_roll: + Raw_context.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + +(**/**) + +val get_contract_delegate: + Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml new file mode 100644 index 000000000..a21e77fc8 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml @@ -0,0 +1,36 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let script_expr_hash = "\013\044\064\027" (* expr(54) *) + +include Blake2B.Make(Base58)(struct + let name = "script_expr" + let title = "A script expression ID" + let b58check_prefix = script_expr_hash + let size = None + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "expr" 54 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml new file mode 100644 index 000000000..7e96549e4 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml @@ -0,0 +1,87 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type n = Natural_tag +type z = Integer_tag +type 't num = Z.t + +let compare x y = Z.compare x y + +let zero = Z.zero +let zero_n = Z.zero + +let to_string x = Z.to_string x +let of_string s = try Some (Z.of_string s) with _ -> None + +let to_int64 x = try Some (Z.to_int64 x) with _ -> None +let of_int64 n = Z.of_int64 n + +let to_int x = try Some (Z.to_int x) with _ -> None +let of_int n = Z.of_int n + +let of_zint x = x +let to_zint x = x + +let add x y = Z.add x y +let sub x y = Z.sub x y +let mul x y = Z.mul x y + +let ediv x y = + try + let (q, r) = Z.ediv_rem x y in + Some (q, r) + with _ -> None + +let add_n = add +let mul_n = mul +let ediv_n = ediv + +let abs x = Z.abs x +let is_nat x = + if Compare.Z.(x < Z.zero) then None else Some x +let neg x = Z.neg x +let int x = x + +let shift_left x y = + if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then + None + else + let y = Z.to_int y in + Some (Z.shift_left x y) + +let shift_right x y = + if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then + None + else + let y = Z.to_int y in + Some (Z.shift_right x y) + +let shift_left_n = shift_left +let shift_right_n = shift_right + +let logor x y = Z.logor x y +let logxor x y = Z.logxor x y +let logand x y = Z.logand x y +let lognot x = Z.lognot x diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli new file mode 100644 index 000000000..592e3a410 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli @@ -0,0 +1,143 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The types for arbitraty precision integers in Michelson. + The type variable ['t] is always [n] or [z], + [n num] and [z num] are incompatible. + + This is internally a [Z.t]. + This module mostly adds signedness preservation guarantees. *) +type 't num + +(** Flag for natural numbers. *) +and n = Natural_tag + +(** Flag for relative numbers. *) +and z = Integer_tag + +(** Natural zero. *) +val zero_n : n num + +(** Relative zero. *) +val zero : z num + +(** Compare two numbers as if they were *) +val compare : 'a num -> 'a num -> int + +(** Conversion to an OCaml [string] in decimal notation. *) +val to_string : _ num -> string + +(** Conversion from an OCaml [string]. + Returns [None] in case of an invalid notation. + Supports [+] and [-] sign modifiers, and [0x], [0o] and [0b] base modifiers. *) +val of_string : string -> z num option + +(** Conversion to an OCaml [int64], returns [None] on overflow. *) +val to_int64 : _ num -> int64 option + +(** Conversion from an OCaml [int]. *) +val of_int64 : int64 -> z num + +(** Conversion to an OCaml [int], returns [None] on overflow. *) +val to_int : _ num -> int option + +(** Conversion from an OCaml [int64]. *) +val of_int : int -> z num + +(** Conversion from a Zarith integer ([Z.t]). *) +val of_zint : Z.t -> z num + +(** Conversion to a Zarith integer ([Z.t]). *) +val to_zint : 'a num -> Z.t + +(** Addition between naturals. *) +val add_n : n num -> n num -> n num + +(** Multiplication between naturals. *) +val mul_n : n num -> n num -> n num + +(** Euclidean division between naturals. + [ediv_n n d] returns [None] if divisor is zero, + or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *) +val ediv_n: n num -> n num -> (n num * n num) option + +(** Sign agnostic addition. + Use {!add_n} when working with naturals to preserve the sign. *) +val add : _ num -> _ num -> z num + +(** Sign agnostic subtraction. + Use {!sub_n} when working with naturals to preserve the sign. *) +val sub : _ num -> _ num -> z num + +(** Sign agnostic multiplication. + Use {!mul_n} when working with naturals to preserve the sign. *) +val mul : _ num -> _ num -> z num + +(** Sign agnostic euclidean division. + [ediv n d] returns [None] if divisor is zero, + or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise. + Use {!ediv_n} when working with naturals to preserve the sign. *) +val ediv: _ num -> _ num -> (z num * n num) option + +(** Compute the absolute value of a relative, turning it into a natural. *) +val abs : z num -> n num + +(** Partial identity over [N]. *) +val is_nat : z num -> n num option + +(** Negates a number. *) +val neg : _ num -> z num + +(** Turns a natural into a relative, not changing its value. *) +val int : n num -> z num + +(** Reverses each bit in the representation of the number. + Also applies to the sign. *) +val lognot : _ num -> z num + +(** Shifts the natural to the left of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_left_n : n num -> n num -> n num option + +(** Shifts the natural to the right of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_right_n : n num -> n num -> n num option + +(** Shifts the number to the left of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_left : 'a num -> n num -> 'a num option + +(** Shifts the number to the right of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_right : 'a num -> n num -> 'a num option + +(** Applies a boolean or operation to each bit. *) +val logor : 'a num -> 'a num -> 'a num + +(** Applies a boolean and operation to each bit. *) +val logand : _ num -> n num -> n num + +(** Applies a boolean xor operation to each bit. *) +val logxor : n num -> n num -> n num diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml new file mode 100644 index 000000000..04229a1aa --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml @@ -0,0 +1,891 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script +open Script_typed_ir +open Script_ir_translator + +(* ---- Run-time errors -----------------------------------------------------*) + +type execution_trace = + (Script.location * Gas.t * (Script.expr * string option) list) list + +type error += Reject of Script.location * Script.expr * execution_trace option +type error += Overflow of Script.location * execution_trace option +type error += Runtime_contract_error : Contract.t * Script.expr -> error +type error += Bad_contract_parameter of Contract.t (* `Permanent *) +type error += Cannot_serialize_log +type error += Cannot_serialize_failure +type error += Cannot_serialize_storage + +let () = + let open Data_encoding in + let trace_encoding = + (list @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req "stack" + (list + (obj2 + (req "item" (Script.expr_encoding)) + (opt "annot" string))))) in + (* Reject *) + register_error_kind + `Temporary + ~id:"michelson_v1.script_rejected" + ~title: "Script failed" + ~description: "A FAILWITH instruction was reached" + (obj3 + (req "location" Script.location_encoding) + (req "with" Script.expr_encoding) + (opt "trace" trace_encoding)) + (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None) + (fun (loc, v, trace) -> Reject (loc, v, trace)); + (* Overflow *) + register_error_kind + `Temporary + ~id:"michelson_v1.script_overflow" + ~title: "Script failed (overflow error)" + ~description: "A FAIL instruction was reached due to the detection of an overflow" + (obj2 + (req "location" Script.location_encoding) + (opt "trace" trace_encoding)) + (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None) + (fun (loc, trace) -> Overflow (loc, trace)); + (* Runtime contract error *) + register_error_kind + `Temporary + ~id:"michelson_v1.runtime_error" + ~title: "Script runtime error" + ~description: "Toplevel error for all runtime script errors" + (obj2 + (req "contract_handle" Contract.encoding) + (req "contract_code" Script.expr_encoding)) + (function + | Runtime_contract_error (contract, expr) -> + Some (contract, expr) + | _ -> None) + (fun (contract, expr) -> + Runtime_contract_error (contract, expr)) ; + (* Bad contract parameter *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_contract_parameter" + ~title:"Contract supplied an invalid parameter" + ~description:"Either no parameter was supplied to a contract with \ + a non-unit parameter type, a non-unit parameter was \ + passed to an account, or a parameter was supplied of \ + the wrong type" + Data_encoding.(obj1 (req "contract" Contract.encoding)) + (function Bad_contract_parameter c -> Some c | _ -> None) + (fun c -> Bad_contract_parameter c) ; + (* Cannot serialize log *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_log" + ~title:"Not enough gas to serialize execution trace" + ~description:"Execution trace with stacks was to big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_log -> Some () | _ -> None) + (fun () -> Cannot_serialize_log) ; + (* Cannot serialize failure *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_failure" + ~title:"Not enough gas to serialize argument of FAILWITH" + ~description:"Argument of FAILWITH was too big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_failure -> Some () | _ -> None) + (fun () -> Cannot_serialize_failure) ; + (* Cannot serialize storage *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_storage" + ~title:"Not enough gas to serialize execution storage" + ~description:"The returned storage was too big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_storage -> Some () | _ -> None) + (fun () -> Cannot_serialize_storage) + +(* ---- interpreter ---------------------------------------------------------*) + +type 'tys stack = + | Item : 'ty * 'rest stack -> ('ty * 'rest) stack + | Empty : end_of_stack stack + +let unparse_stack ctxt (stack, stack_ty) = + (* We drop the gas limit as this function is only used for debugging/errors. *) + let ctxt = Gas.set_unlimited ctxt in + let rec unparse_stack + : type a. a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t + = function + | Empty, Empty_t -> return_nil + | Item (v, rest), Item_t (ty, rest_ty, annot) -> + unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) -> + unparse_stack (rest, rest_ty) >>=? fun rest -> + let annot = match Script_ir_annot.unparse_var_annot annot with + | [] -> None + | [ a ] -> Some a + | _ -> assert false in + let data = Micheline.strip_locations data in + return ((data, annot) :: rest) in + unparse_stack (stack, stack_ty) + +module Interp_costs = Michelson_v1_gas.Cost_of + +let rec interp + : type p r. + (?log: execution_trace ref -> + context -> + source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> + (p, r) lambda -> p -> + (r * context) tzresult Lwt.t) + = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> + let rec step + : type b a. + context -> (b, a) descr -> b stack -> + (a stack * context) tzresult Lwt.t = + fun ctxt ({ instr ; loc ; _ } as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> + let logged_return : type a b. + (b, a) descr -> + a stack * context -> + (a stack * context) tzresult Lwt.t = + fun descr (ret, ctxt) -> + match log with + | None -> return (ret, ctxt) + | Some log -> + trace + Cannot_serialize_log + (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> + log := (descr.loc, Gas.level ctxt, stack) :: !log ; + return (ret, ctxt) in + let get_log (log : execution_trace ref option) = + Option.map ~f:(fun l -> List.rev !l) log in + let consume_gas_terop : type ret arg1 arg2 arg3 rest. + (_ * (_ * (_ * rest)), ret * rest) descr -> + ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + (arg1 -> arg2 -> arg3 -> Gas.cost) -> + rest stack -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2 x3, rest), ctxt) in + let consume_gas_binop : type ret arg1 arg2 rest. + (_ * (_ * rest), ret * rest) descr -> + ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + (arg1 -> arg2 -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2, rest), ctxt) in + let consume_gas_unop : type ret arg rest. + (_ * rest, ret * rest) descr -> + ((arg -> ret) * arg) -> + (arg -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + logged_return descr (Item (op arg, rest), ctxt) in + let consume_gaz_comparison : + type t rest. + (t * (t * rest), Script_int.z Script_int.num * rest) descr -> + (t -> t -> int) -> + (t -> t -> Gas.cost) -> + t -> t -> + rest stack -> + ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = + fun descr op cost x1 x2 rest -> + Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in + let logged_return : + a stack * context -> + (a stack * context) tzresult Lwt.t = + logged_return descr in + match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (rest, ctxt) + | Dup, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (v, Item (v, rest)), ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (vo, Item (vi, rest)), ctxt) + | Const v, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (Some v, rest), ctxt) + | Cons_none _, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | If_none (bt, _), Item (None, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bt rest + | If_none (_, bf), Item (Some v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + logged_return (Item ((a, b), rest), ctxt) + | Car, Item ((a, _), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, rest), ctxt) + | Cdr, Item ((_, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (b, rest), ctxt) + (* unions *) + | Left, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (L v, rest), ctxt) + | Right, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (R v, rest), ctxt) + | If_left (bt, _), Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + logged_return (Item (hd :: tl, rest), ctxt) + | Nil, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item ([], rest), ctxt) + | If_cons (_, bf), Item ([], rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bt (Item (hd, Item (tl, rest))) + | List_map body, Item (l, rest) -> + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (Item (List.rev acc, rest), ctxt) + | hd :: tl -> + step ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (hd :: acc) + in loop rest ctxt l [] >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | List_size, Item (list, rest) -> + Lwt.return + (List.fold_left + (fun acc _ -> + acc >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> + ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | List_iter body, Item (l, init) -> + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + (* sets *) + | Empty_set t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + logged_return (Item (empty_set t, rest), ctxt) + | Set_iter body, Item (set, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Set_mem, Item (v, Item (set, rest)) -> + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + | Set_update, Item (v, Item (presence, Item (set, rest))) -> + consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + | Set_size, Item (set, rest) -> + consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + (* maps *) + | Empty_map (t, _), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (empty_map t, rest), ctxt) + | Map_map body, Item (map, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt) + | (k, _) as hd :: tl -> + step ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Map_iter body, Item (map, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Map_mem, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + | Map_get, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + | Map_update, Item (k, Item (v, Item (map, rest))) -> + consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest + | Map_size, Item (map, rest) -> + consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + (* Big map operations *) + | Big_map_mem, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> + Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_get, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> + Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + consume_gas_terop descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + Interp_costs.big_map_update rest + (* timestamp operations *) + | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + consume_gas_binop descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + consume_gas_binop descr (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + consume_gas_binop descr (Script_timestamp.sub_delta, t, s) + Interp_costs.sub_timestamp rest ctxt + | Diff_timestamps, Item (t1, Item (t2, rest)) -> + consume_gas_binop descr (Script_timestamp.diff, t1, t2) + Interp_costs.diff_timestamps rest ctxt + (* string operations *) + | Concat_string_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> + let s = String.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_string, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_string, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | String_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | Concat_bytes_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> + let s = MBytes.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_bytes, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> + let s = MBytes.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (MBytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Bytes_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x +? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x -? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Mul_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + | Mul_nattez, Item (y, Item (x, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + | And, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + | Xor, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + | Not, Item (x, rest) -> + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + (* integer operations *) + | Is_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + | Abs_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + | Int_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + | Neg_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Neg_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Add_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + | Sub_int, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + | Mul_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + | Ediv_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + consume_gas_binop descr + ((fun x y -> + match Script_int.ediv x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 q, + Script_int.to_int64 r with + | Some q, Some r -> + begin + match Tez.of_mutez q, Tez.of_mutez r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in + consume_gas_binop descr + ((fun x y -> match Script_int.ediv_n x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_mutez r with + | None -> assert false (* Cannot overflow *) + | Some r -> Some (q, r)), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + | Lsl_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + begin + match Script_int.shift_left_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some x -> logged_return (Item (x, rest), ctxt) + end + | Lsr_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + begin + match Script_int.shift_right_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some r -> logged_return (Item (r, rest), ctxt) + end + | Or_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + | And_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | And_int_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | Xor_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + | Not_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + | Not_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + (* control *) + | Seq (hd, tl), stack -> + step ctxt hd stack >>=? fun (trans, ctxt) -> + step ctxt tl trans + | If (bt, _), Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bt rest + | If (_, bf), Item (false, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ctxt bf rest + | Loop body, Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step ctxt body rest >>=? fun (trans, ctxt) -> + step ctxt descr trans + | Loop _, Item (false, rest) -> + logged_return (rest, ctxt) + | Loop_left body, Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> + step ctxt descr trans + | Loop_left _, Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + | Dip b, Item (ign, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + step ctxt b rest >>=? fun (res, ctxt) -> + logged_return (Item (ign, res), ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Lambda lam, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (lam, rest), ctxt) + | Failwith tv, Item (v, _) -> + trace Cannot_serialize_failure + (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (loc, v, get_log log)) + | Nop, stack -> + logged_return (stack, ctxt) + (* comparison *) + | Compare (Bool_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest + | Compare (String_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest + | Compare (Bytes_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest + | Compare (Mutez_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest + | Compare (Int_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest + | Compare (Nat_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest + | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Signature.Public_key_hash.compare + Interp_costs.compare_key_hash a b rest + | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest + | Compare (Address_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + (* packing *) + | Pack t, Item (value, rest) -> + Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> + logged_return (Item (bytes, rest), ctxt) + | Unpack t, Item (bytes, rest) -> + Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> + if Compare.Int.(MBytes.length bytes >= 1) && + Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Some expr -> + Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> + parse_data ctxt t (Micheline.root expr) >>= function + | Ok (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + | Error _ignored -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + else + logged_return (Item (None, rest), ctxt) + (* protocol *) + | Address, Item ((_, contract), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> + logged_return (Item (contract, rest), ctxt) + | Contract t, Item (contract, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> + Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) + | Transfer_tokens, + Item (p, Item (amount, Item ((tp, destination), rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> + unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> + let operation = + Transaction + { amount ; destination ; + parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + | Create_account, + Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; manager ; delegate ; preorigination = Some contract ; + delegatable ; script = None ; spendable = true } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, + Item (contract, rest)), ctxt) + | Implicit_account, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> + let contract = Contract.implicit_contract key in + logged_return (Item ((Unit_t None, contract), rest), ctxt) + | Create_contract (storage_type, param_type, Lam (_, code)), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (init, rest)))))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ Micheline.root code ], []) ])) in + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; manager ; delegate ; preorigination = Some contract ; + delegatable ; spendable ; + script = Some { code = Script.lazy_expr code ; + storage = Script.lazy_expr storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item (Internal_operation { source = self ; operation ; nonce }, + Item (contract, rest)), ctxt) + | Set_delegate, + Item (delegate, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + let operation = Delegation delegate in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + | Balance, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> + Contract.get_balance ctxt self >>=? fun balance -> + logged_return (Item (balance, rest), ctxt) + | Now, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), ctxt) + | Check_signature, Item (key, Item (signature, Item (message, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> + let res = Signature.check key signature message in + logged_return (Item (res, rest), ctxt) + | Hash_key, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + | Blake2b, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + let hash = Raw_hashes.blake2b bytes in + logged_return (Item (hash, rest), ctxt) + | Sha256, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + let hash = Raw_hashes.sha256 bytes in + logged_return (Item (hash, rest), ctxt) + | Sha512, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> + let hash = Raw_hashes.sha512 bytes in + logged_return (Item (hash, rest), ctxt) + | Steps_to_quota, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + let steps = match Gas.level ctxt with + | Limited { remaining } -> remaining + | Unaccounted -> Z.of_string "99999999" in + logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + | Source, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item (payer, rest), ctxt) + | Sender, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item (source, rest), ctxt) + | Self t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + logged_return (Item ((t,self), rest), ctxt) + | Amount, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + logged_return (Item (amount, rest), ctxt) in + let stack = (Item (arg, Empty)) in + begin match log with + | None -> return_unit + | Some log -> + trace Cannot_serialize_log + (unparse_stack ctxt (stack, code.bef)) >>=? fun stack -> + log := (code.loc, Gas.level ctxt, stack) :: !log ; + return_unit + end >>=? fun () -> + step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) -> + return (ret, ctxt) + +(* ---- contract handling ---------------------------------------------------*) + +and execute ?log ctxt mode ~source ~payer ~self script amount arg : + (Script.expr * packed_internal_operation list * context * + Script_typed_ir.ex_big_map option) tzresult Lwt.t = + parse_script ctxt script + >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) -> + trace + (Bad_contract_parameter self) + (parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) -> + Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) -> + trace + (Runtime_contract_error (self, script_code)) + (interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) + >>=? fun ((ops, sto), ctxt) -> + trace Cannot_serialize_storage + (unparse_data ctxt mode storage_type sto) >>=? fun (storage, ctxt) -> + return (Micheline.strip_locations storage, ops, ctxt, + Script_ir_translator.extract_big_map storage_type sto) + +type execution_result = + { ctxt : context ; + storage : Script.expr ; + big_map_diff : Contract.big_map_diff option ; + operations : packed_internal_operation list } + +let trace ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount = + let log = ref [] in + execute ~log ctxt mode ~source ~payer ~self script amount (Micheline.root parameter) + >>=? fun (storage, operations, ctxt, big_map) -> + begin match big_map with + | None -> return (None, ctxt) + | Some big_map -> + Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) -> + return (Some big_map_diff, ctxt) + end >>=? fun (big_map_diff, ctxt) -> + let trace = List.rev !log in + return ({ ctxt ; storage ; big_map_diff ; operations }, trace) + +let execute ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount = + execute ctxt mode ~source ~payer ~self script amount (Micheline.root parameter) + >>=? fun (storage, operations, ctxt, big_map) -> + begin match big_map with + | None -> return (None, ctxt) + | Some big_map -> + Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) -> + return (Some big_map_diff, ctxt) + end >>=? fun (big_map_diff, ctxt) -> + return { ctxt ; storage ; big_map_diff ; operations } diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli new file mode 100644 index 000000000..d333515cd --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli @@ -0,0 +1,67 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type execution_trace = + (Script.location * Gas.t * (Script.expr * string option) list) list + +type error += Reject of Script.location * Script.expr * execution_trace option +type error += Overflow of Script.location * execution_trace option +type error += Runtime_contract_error : Contract.t * Script.expr -> error +type error += Bad_contract_parameter of Contract.t (* `Permanent *) +type error += Cannot_serialize_log +type error += Cannot_serialize_failure +type error += Cannot_serialize_storage + +type execution_result = + { ctxt : context ; + storage : Script.expr ; + big_map_diff : Contract.big_map_diff option ; + operations : packed_internal_operation list } + +type 'tys stack = + | Item : 'ty * 'rest stack -> ('ty * 'rest) stack + | Empty : Script_typed_ir.end_of_stack stack + +val execute: + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + source: Contract.t -> + payer: Contract.t -> + self: (Contract.t * Script.t) -> + parameter: Script.expr -> + amount: Tez.t -> + execution_result tzresult Lwt.t + +val trace: + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + source: Contract.t -> + payer: Contract.t -> + self: (Contract.t * Script.t) -> + parameter: Script.expr -> + amount: Tez.t -> + (execution_result * execution_trace) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml new file mode 100644 index 000000000..57c0af937 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml @@ -0,0 +1,413 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Micheline +open Script_tc_errors +open Script_typed_ir + +let default_now_annot = Some (`Var_annot "now") +let default_amount_annot = Some (`Var_annot "amount") +let default_balance_annot = Some (`Var_annot "balance") +let default_steps_annot = Some (`Var_annot "steps") +let default_source_annot = Some (`Var_annot "source") +let default_sender_annot = Some (`Var_annot "sender") +let default_self_annot = Some (`Var_annot "self") +let default_arg_annot = Some (`Var_annot "arg") +let default_param_annot = Some (`Var_annot "parameter") +let default_storage_annot = Some (`Var_annot "storage") + +let default_car_annot = Some (`Field_annot "car") +let default_cdr_annot = Some (`Field_annot "cdr") +let default_contract_annot = Some (`Field_annot "contract") +let default_addr_annot = Some (`Field_annot "address") +let default_manager_annot = Some (`Field_annot "manager") +let default_pack_annot = Some (`Field_annot "packed") +let default_unpack_annot = Some (`Field_annot "unpacked") +let default_slice_annot = Some (`Field_annot "slice") + +let default_elt_annot = Some (`Field_annot "elt") +let default_key_annot = Some (`Field_annot "key") +let default_hd_annot = Some (`Field_annot "hd") +let default_tl_annot = Some (`Field_annot "tl") +let default_some_annot = Some (`Field_annot "some") +let default_left_annot = Some (`Field_annot "left") +let default_right_annot = Some (`Field_annot "right") +let default_binding_annot = Some (`Field_annot "bnd") + +let unparse_type_annot : type_annot option -> string list = function + | None -> [] + | Some `Type_annot a -> [ ":" ^ a ] + +let unparse_var_annot : var_annot option -> string list = function + | None -> [] + | Some `Var_annot a -> [ "@" ^ a ] + +let unparse_field_annot : field_annot option -> string list = function + | None -> [] + | Some `Field_annot a -> [ "%" ^ a ] + +let field_to_var_annot : field_annot option -> var_annot option = + function + | None -> None + | Some (`Field_annot s) -> Some (`Var_annot s) + +let type_to_var_annot : type_annot option -> var_annot option = + function + | None -> None + | Some (`Type_annot s) -> Some (`Var_annot s) + +let var_to_field_annot : var_annot option -> field_annot option = + function + | None -> None + | Some (`Var_annot s) -> Some (`Field_annot s) + +let default_annot ~default = function + | None -> default + | annot -> annot + +let gen_access_annot + : var_annot option -> ?default:field_annot option -> field_annot option -> var_annot option + = fun value_annot ?(default=None) field_annot -> + match value_annot, field_annot, default with + | None, None, _ | Some _, None, None | None, Some `Field_annot "", _ -> None + | None, Some `Field_annot f, _ -> + Some (`Var_annot f) + | Some `Var_annot v, (None | Some `Field_annot ""), Some `Field_annot f -> + Some (`Var_annot (String.concat "." [v; f])) + | Some `Var_annot v, Some `Field_annot f, _ -> + Some (`Var_annot (String.concat "." [v; f])) + +let merge_type_annot + : type_annot option -> type_annot option -> type_annot option tzresult + = fun annot1 annot2 -> + match annot1, annot2 with + | None, None + | Some _, None + | None, Some _ -> ok None + | Some `Type_annot a1, Some `Type_annot a2 -> + if String.equal a1 a2 + then ok annot1 + else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) + +let merge_field_annot + : field_annot option -> field_annot option -> field_annot option tzresult + = fun annot1 annot2 -> + match annot1, annot2 with + | None, None + | Some _, None + | None, Some _ -> ok None + | Some `Field_annot a1, Some `Field_annot a2 -> + if String.equal a1 a2 + then ok annot1 + else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) + +let merge_var_annot + : var_annot option -> var_annot option -> var_annot option + = fun annot1 annot2 -> + match annot1, annot2 with + | None, None + | Some _, None + | None, Some _ -> None + | Some `Var_annot a1, Some `Var_annot a2 -> + if String.equal a1 a2 then annot1 else None + +let error_unexpected_annot loc annot = + match annot with + | [] -> ok () + | _ :: _ -> error (Unexpected_annotation loc) + +let fail_unexpected_annot loc annot = + Lwt.return (error_unexpected_annot loc annot) + +let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) l = + (* allow emtpty annotations as wildcards but otherwise only accept + annotations that start with [a-zA-Z_] *) + let sub_or_wildcard ~specials wrap s acc = + let len = String.length s in + if Compare.Int.(len = 1) then ok @@ wrap None :: acc + else match s.[1] with + | 'a' .. 'z' | 'A' .. 'Z' | '_' -> + ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc + | '@' when Compare.Int.(len = 2) && List.mem '@' specials -> + ok @@ wrap (Some "@") :: acc + | '%' when List.mem '%' specials -> + if Compare.Int.(len = 2) + then ok @@ wrap (Some "%") :: acc + else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') + then ok @@ wrap (Some "%%") :: acc + else error (Unexpected_annotation loc) + | _ -> error (Unexpected_annotation loc) in + List.fold_left (fun acc s -> + acc >>? fun acc -> + if Compare.Int.(String.length s = 0) then + error (Unexpected_annotation loc) + else match s.[0] with + | ':' -> sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc + | '@' -> + sub_or_wildcard + ~specials:(if allow_special_var then ['%'] else []) + (fun a -> `Var_annot a) s acc + | '%' -> sub_or_wildcard + ~specials:(if allow_special_field then ['@'] else []) + (fun a -> `Field_annot a) s acc + | _ -> error (Unexpected_annotation loc) + ) (ok []) l + >|? List.rev + +let opt_var_of_var_opt = function + | `Var_annot None -> None + | `Var_annot Some a -> Some (`Var_annot a) + +let opt_field_of_field_opt = function + | `Field_annot None -> None + | `Field_annot Some a -> Some (`Field_annot a) + +let opt_type_of_type_opt = function + | `Type_annot None -> None + | `Type_annot Some a -> Some (`Type_annot a) + +let classify_annot loc l + : (var_annot option list * type_annot option list * field_annot option list) tzresult + = + try + let _, rv, _, rt, _, rf = + List.fold_left + (fun (in_v, rv, in_t, rt, in_f, rf) a -> + match a, in_v, rv, in_t, rt, in_f, rf with + | (`Var_annot _ as a), true, _, _, _, _, _ + | (`Var_annot _ as a), false, [], _, _, _, _ -> + true, opt_var_of_var_opt a :: rv, + false, rt, + false, rf + | (`Type_annot _ as a), _, _, true, _, _, _ + | (`Type_annot _ as a), _, _, false, [], _, _ -> + false, rv, + true, opt_type_of_type_opt a :: rt, + false, rf + | (`Field_annot _ as a), _, _, _, _, true, _ + | (`Field_annot _ as a), _, _, _, _, false, [] -> + false, rv, + false, rt, + true, opt_field_of_field_opt a :: rf + | _ -> raise Exit + ) (false, [], false, [], false, []) l in + ok (List.rev rv, List.rev rt, List.rev rf) + with Exit -> error (Ungrouped_annotations loc) + +let get_one_annot loc = function + | [] -> ok None + | [ a ] -> ok a + | _ -> error (Unexpected_annotation loc) + +let get_two_annot loc = function + | [] -> ok (None, None) + | [ a ] -> ok (a, None) + | [ a; b ] -> ok (a, b) + | _ -> error (Unexpected_annotation loc) + +let parse_type_annot + : int -> string list -> type_annot option tzresult + = fun loc annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> + get_one_annot loc types + +let parse_type_field_annot + : int -> string list -> (type_annot option * field_annot option) tzresult + = fun loc annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars >>? fun () -> + get_one_annot loc types >>? fun t -> + get_one_annot loc fields >|? fun f -> + (t, f) + +let parse_composed_type_annot + : int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult + = fun loc annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars >>? fun () -> + get_one_annot loc types >>? fun t -> + get_two_annot loc fields >|? fun (f1, f2) -> + (t, f1, f2) + +let check_const_type_annot + : int -> string list -> type_annot option -> field_annot option list -> unit tzresult Lwt.t + = fun loc annot expected_name expected_fields -> + Lwt.return + (parse_composed_type_annot loc annot >>? fun (ty_name, field1, field2) -> + merge_type_annot expected_name ty_name >>? fun _ -> + match expected_fields, field1, field2 with + | [], Some _, _ | [], _, Some _ | [_], Some _, Some _ -> + (* Too many annotations *) + error (Unexpected_annotation loc) + | _ :: _ :: _ :: _, _, _ | [_], None, Some _ -> + error (Unexpected_annotation loc) + | [], None, None -> ok () + | [ f1; f2 ], _, _ -> + merge_field_annot f1 field1 >>? fun _ -> + merge_field_annot f2 field2 >|? fun _ -> () + | [ f1 ], _, None -> + merge_field_annot f1 field1 >|? fun _ -> () + ) + +let parse_field_annot + : int -> string list -> field_annot option tzresult + = fun loc annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars >>? fun () -> + error_unexpected_annot loc types >>? fun () -> + get_one_annot loc fields + +let extract_field_annot + : Script.node -> (Script.node * field_annot option) tzresult + = function + | Prim (loc, prim, args, annot) -> + let field_annots, annot = List.partition (fun s -> + Compare.Int.(String.length s > 0) && + Compare.Char.(s.[0] = '%') + ) annot in + parse_field_annot loc field_annots >|? fun field_annot -> + Prim (loc, prim, args, annot), field_annot + | expr -> ok (expr, None) + +let check_correct_field + : field_annot option -> field_annot option -> unit tzresult + = fun f1 f2 -> + match f1, f2 with + | None, _ | _, None -> ok () + | Some `Field_annot s1, Some `Field_annot s2 -> + if String.equal s1 s2 then ok () + else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2)) + + +let parse_var_annot + : int -> ?default:var_annot option -> string list -> + var_annot option tzresult + = fun loc ?default annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc types >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> + get_one_annot loc vars >|? function + | Some _ as a -> a + | None -> match default with + | Some a -> a + | None -> None + +let split_last_dot = function + | None -> None, None + | Some `Field_annot s -> + match String.rindex_opt s '.' with + | None -> None, Some (`Field_annot s) + | Some i -> + let s1 = String.sub s 0 i in + let s2 = String.sub s (i + 1) (String.length s - i - 1) in + let f = + if Compare.String.equal s2 "car" + || Compare.String.equal s2 "cdr" then + None + else + Some (`Field_annot s2) in + Some (`Var_annot s1), f + +let common_prefix v1 v2 = + match v1, v2 with + | Some (`Var_annot s1), Some (`Var_annot s2) when Compare.String.equal s1 s2 -> v1 + | Some _, None -> v1 + | None, Some _ -> v2 + | _, _ -> None + +let parse_constr_annot + : int -> + ?if_special_first:field_annot option -> + ?if_special_second:field_annot option -> + string list -> + (var_annot option * type_annot option * field_annot option * field_annot option) tzresult + = fun loc ?if_special_first ?if_special_second annot -> + parse_annots ~allow_special_field:true loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + get_one_annot loc vars >>? fun v -> + get_one_annot loc types >>? fun t -> + get_two_annot loc fields >>? fun (f1, f2) -> + begin match if_special_first, f1 with + | Some special_var, Some `Field_annot "@" -> + ok (split_last_dot special_var) + | None, Some `Field_annot "@" -> error (Unexpected_annotation loc) + | _, _ -> ok (v, f1) + end >>? fun (v1, f1) -> + begin match if_special_second, f2 with + | Some special_var, Some `Field_annot "@" -> + ok (split_last_dot special_var) + | None, Some `Field_annot "@" -> error (Unexpected_annotation loc) + | _, _ -> ok (v, f2) + end >|? fun (v2, f2) -> + let v = match v with + | None -> common_prefix v1 v2 + | Some _ -> v in + (v, t, f1, f2) + +let parse_two_var_annot + : int -> string list -> (var_annot option * var_annot option) tzresult + = fun loc annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc types >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> + get_two_annot loc vars + +let parse_destr_annot + : int -> string list -> default_accessor:field_annot option -> + field_name:field_annot option -> + pair_annot:var_annot option -> value_annot:var_annot option -> + (var_annot option * field_annot option) tzresult + = fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot -> + parse_annots loc ~allow_special_var:true annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc types >>? fun () -> + get_one_annot loc vars >>? fun v -> + get_one_annot loc fields >|? fun f -> + let default = gen_access_annot pair_annot field_name ~default:default_accessor in + let v = match v with + | Some `Var_annot "%" -> field_to_var_annot field_name + | Some `Var_annot "%%" -> default + | Some _ -> v + | None -> value_annot in + (v, f) + +let parse_var_type_annot + : int -> string list -> (var_annot option * type_annot option) tzresult + = fun loc annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc fields >>? fun () -> + get_one_annot loc vars >>? fun v -> + get_one_annot loc types >|? fun t -> + (v, t) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli new file mode 100644 index 000000000..0ad19733a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli @@ -0,0 +1,161 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_typed_ir + +(** Default annotations *) + +val default_now_annot : var_annot option +val default_amount_annot : var_annot option +val default_balance_annot : var_annot option +val default_steps_annot : var_annot option +val default_source_annot : var_annot option +val default_sender_annot : var_annot option +val default_self_annot : var_annot option +val default_arg_annot : var_annot option +val default_param_annot : var_annot option +val default_storage_annot : var_annot option + +val default_car_annot : field_annot option +val default_cdr_annot : field_annot option +val default_contract_annot : field_annot option +val default_addr_annot : field_annot option +val default_manager_annot : field_annot option +val default_pack_annot : field_annot option +val default_unpack_annot : field_annot option +val default_slice_annot : field_annot option + +val default_elt_annot : field_annot option +val default_key_annot : field_annot option +val default_hd_annot : field_annot option +val default_tl_annot : field_annot option +val default_some_annot : field_annot option +val default_left_annot : field_annot option +val default_right_annot : field_annot option +val default_binding_annot : field_annot option + +(** Unparse annotations to their string representation *) + +val unparse_type_annot : type_annot option -> string list +val unparse_var_annot : var_annot option -> string list +val unparse_field_annot : field_annot option -> string list + +(** Convertions functions between different annotation kinds *) + +val field_to_var_annot : field_annot option -> var_annot option +val type_to_var_annot : type_annot option -> var_annot option +val var_to_field_annot : var_annot option -> field_annot option + +(** Replace an annotation by its default value if it is [None] *) +val default_annot : default:'a option -> 'a option -> 'a option + +(** Generate annotation for field accesses, of the form @var.field1.field2 *) +val gen_access_annot : + var_annot option -> + ?default:field_annot option -> field_annot option -> var_annot option + +(** Merge type annotations. + @returns an error {!Inconsistent_type_annotations} if they are both present + and different *) +val merge_type_annot : + type_annot option -> type_annot option -> type_annot option tzresult + +(** Merge field annotations. + @returns an error {!Inconsistent_type_annotations} if they are both present + and different *) +val merge_field_annot : + field_annot option -> field_annot option -> field_annot option tzresult + +(** Merge variable annotations, does not fail ([None] if different). *) +val merge_var_annot : + var_annot option -> var_annot option -> var_annot option + +(** @returns an error {!Unexpected_annotation} in the monad the list is not empty. *) +val error_unexpected_annot : int -> 'a list -> unit tzresult + +(** Same as {!error_unexpected_annot} in Lwt. *) +val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t + +(** Parse a type annotation only. *) +val parse_type_annot : int -> string list -> type_annot option tzresult + +(** Parse a field annotation only. *) +val parse_field_annot : + int -> string list -> field_annot option tzresult + +(** Parse an annotation for composed types, of the form + [:ty_name %field] in any order. *) +val parse_type_field_annot : + int -> string list -> (type_annot option * field_annot option) tzresult + +(** Parse an annotation for composed types, of the form + [:ty_name %field1 %field2] in any order. *) +val parse_composed_type_annot : + int -> string list -> + (type_annot option * field_annot option * field_annot option) tzresult + +(** Check that type annotations on constants are consistent *) +val check_const_type_annot : + int -> string list -> type_annot option -> field_annot option list -> + unit tzresult Lwt.t + +(** Extract and remove a field annotation from a node *) +val extract_field_annot : + Script.node -> (Script.node * field_annot option) tzresult + +(** Check that field annotations match, used for field accesses. *) +val check_correct_field : + field_annot option -> field_annot option -> unit tzresult + +(** Instruction annotations parsing *) + +(** Parse a variable annotation, replaced by a default value if [None]. *) +val parse_var_annot : + int -> + ?default:var_annot option -> + string list -> var_annot option tzresult + +val parse_constr_annot : + int -> + ?if_special_first:field_annot option -> + ?if_special_second:field_annot option -> + string list -> + (var_annot option * type_annot option * + field_annot option * field_annot option) tzresult + +val parse_two_var_annot : + int -> string list -> (var_annot option * var_annot option) tzresult + +val parse_destr_annot : + int -> string list -> + default_accessor:field_annot option -> + field_name:field_annot option -> + pair_annot:var_annot option -> + value_annot:var_annot option -> + (var_annot option * field_annot option) tzresult + +val parse_var_type_annot : + int -> string list -> (var_annot option * type_annot option) tzresult diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml new file mode 100644 index 000000000..7deac7920 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml @@ -0,0 +1,3236 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Micheline +open Script +open Script_typed_ir +open Script_tc_errors +open Script_ir_annot + +module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking +module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse + +type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty +type ex_ty = Ex_ty : 'a ty -> ex_ty +type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty + +type tc_context = + | Lambda : tc_context + | Dip : 'a stack_ty * tc_context -> tc_context + | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty } -> tc_context + +type unparsing_mode = Optimized | Readable + +type type_logger = + int -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit + +let add_dip ty annot prev = + match prev with + | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev) + | Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev) + +(* ---- Type size accounting ------------------------------------------------*) + +(* TODO include annot in size ? *) +let comparable_type_size : type t. t comparable_ty -> int = fun ty -> + (* No wildcard to force the update when comparable_ty chages. *) + match ty with + | Int_key _ -> 1 + | Nat_key _ -> 1 + | String_key _ -> 1 + | Bytes_key _ -> 1 + | Mutez_key _ -> 1 + | Bool_key _ -> 1 + | Key_hash_key _ -> 1 + | Timestamp_key _ -> 1 + | Address_key _ -> 1 + +(* TODO include annot in size ? *) +let rec type_size : type t. t ty -> int = + fun ty -> match ty with + | Unit_t _ -> 1 + | Int_t _ -> 1 + | Nat_t _ -> 1 + | Signature_t _ -> 1 + | Bytes_t _ -> 1 + | String_t _ -> 1 + | Mutez_t _ -> 1 + | Key_hash_t _ -> 1 + | Key_t _ -> 1 + | Timestamp_t _ -> 1 + | Address_t _ -> 1 + | Bool_t _ -> 1 + | Operation_t _ -> 1 + | Pair_t ((l, _, _), (r, _, _), _) -> + 1 + type_size l + type_size r + | Union_t ((l, _), (r, _), _) -> + 1 + type_size l + type_size r + | Lambda_t (arg, ret, _) -> + 1 + type_size arg + type_size ret + | Option_t ((t,_), _, _) -> + 1 + type_size t + | List_t (t, _) -> + 1 + type_size t + | Set_t (k, _) -> + 1 + comparable_type_size k + | Map_t (k, v, _) -> + 1 + comparable_type_size k + type_size v + | Big_map_t (k, v, _) -> + 1 + comparable_type_size k + type_size v + | Contract_t (arg, _) -> + 1 + type_size arg + +let rec type_size_of_stack_head + : type st. st stack_ty -> up_to:int -> int + = fun stack ~up_to -> + match stack with + | Empty_t -> 0 + | Item_t (head, tail, _annot) -> + if Compare.Int.(up_to > 0) then + Compare.Int.max (type_size head) + (type_size_of_stack_head tail ~up_to:(up_to - 1)) + else + 0 + +(* This is the depth of the stack to inspect for sizes overflow. We + only need to check the produced types that can be larger than the + arguments. That's why Swap is 0 for instance as no type grows. + Constant sized types are not checked: it is assumed they are lower + than the bound (otherwise every program would be rejected). *) +let number_of_generated_growing_types : type b a. (b, a) instr -> int = function + | Drop -> 0 + | Dup -> 0 + | Swap -> 0 + | Const _ -> 1 + | Cons_pair -> 1 + | Car -> 0 + | Cdr -> 0 + | Cons_some -> 1 + | Cons_none _ -> 1 + | If_none _ -> 0 + | Left -> 0 + | Right -> 0 + | If_left _ -> 0 + | Cons_list -> 1 + | Nil -> 1 + | If_cons _ -> 0 + | List_map _ -> 1 + | List_size -> 0 + | List_iter _ -> 1 + | Empty_set _ -> 1 + | Set_iter _ -> 0 + | Set_mem -> 0 + | Set_update -> 0 + | Set_size -> 0 + | Empty_map _ -> 1 + | Map_map _ -> 1 + | Map_iter _ -> 1 + | Map_mem -> 0 + | Map_get -> 0 + | Map_update -> 0 + | Map_size -> 0 + | Big_map_get -> 0 + | Big_map_update -> 0 + | Big_map_mem -> 0 + | Concat_string -> 0 + | Concat_string_pair -> 0 + | Slice_string -> 0 + | String_size -> 0 + | Concat_bytes -> 0 + | Concat_bytes_pair -> 0 + | Slice_bytes -> 0 + | Bytes_size -> 0 + | Add_seconds_to_timestamp -> 0 + | Add_timestamp_to_seconds -> 0 + | Sub_timestamp_seconds -> 0 + | Diff_timestamps -> 0 + | Add_tez -> 0 + | Sub_tez -> 0 + | Mul_teznat -> 0 + | Mul_nattez -> 0 + | Ediv_teznat -> 0 + | Ediv_tez -> 0 + | Or -> 0 + | And -> 0 + | Xor -> 0 + | Not -> 0 + | Is_nat -> 0 + | Neg_nat -> 0 + | Neg_int -> 0 + | Abs_int -> 0 + | Int_nat -> 0 + | Add_intint -> 0 + | Add_intnat -> 0 + | Add_natint -> 0 + | Add_natnat -> 0 + | Sub_int -> 0 + | Mul_intint -> 0 + | Mul_intnat -> 0 + | Mul_natint -> 0 + | Mul_natnat -> 0 + | Ediv_intint -> 0 + | Ediv_intnat -> 0 + | Ediv_natint -> 0 + | Ediv_natnat -> 0 + | Lsl_nat -> 0 + | Lsr_nat -> 0 + | Or_nat -> 0 + | And_nat -> 0 + | And_int_nat -> 0 + | Xor_nat -> 0 + | Not_nat -> 0 + | Not_int -> 0 + | Seq _ -> 0 + | If _ -> 0 + | Loop _ -> 0 + | Loop_left _ -> 0 + | Dip _ -> 0 + | Exec -> 0 + | Lambda _ -> 1 + | Failwith _ -> 1 + | Nop -> 0 + | Compare _ -> 1 + | Eq -> 0 + | Neq -> 0 + | Lt -> 0 + | Gt -> 0 + | Le -> 0 + | Ge -> 0 + | Address -> 0 + | Contract _ -> 1 + | Transfer_tokens -> 1 + | Create_account -> 0 + | Implicit_account -> 0 + | Create_contract _ -> 1 + | Now -> 0 + | Balance -> 0 + | Check_signature -> 0 + | Hash_key -> 0 + | Blake2b -> 0 + | Sha256 -> 0 + | Sha512 -> 0 + | Steps_to_quota -> 0 + | Source -> 0 + | Sender -> 0 + | Self _ -> 1 + | Amount -> 0 + | Set_delegate -> 0 + | Pack _ -> 0 + | Unpack _ -> 1 + +(* ---- Error helpers -------------------------------------------------------*) + +let location = function + | Prim (loc, _, _, _) + | Int (loc, _) + | String (loc, _) + | Bytes (loc, _) + | Seq (loc, _) -> loc + +let kind = function + | Int _ -> Int_kind + | String _ -> String_kind + | Bytes _ -> Bytes_kind + | Prim _ -> Prim_kind + | Seq _ -> Seq_kind + +let namespace = function + | K_parameter + | K_storage + | K_code -> Keyword_namespace + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit -> Constant_namespace + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME -> Instr_namespace + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address -> Type_namespace + + +let unexpected expr exp_kinds exp_ns exp_prims = + match expr with + | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) + | String (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) + | Bytes (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind) + | Seq (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) + | Prim (loc, name, _, _) -> + match namespace name, exp_ns with + | Type_namespace, Type_namespace + | Instr_namespace, Instr_namespace + | Constant_namespace, Constant_namespace -> + Invalid_primitive (loc, exp_prims, name) + | ns, _ -> + Invalid_namespace (loc, name, exp_ns, ns) + +let check_kind kinds expr = + let kind = kind expr in + if List.mem kind kinds then + return_unit + else + let loc = location expr in + fail (Invalid_kind (loc, kinds, kind)) + +(* ---- Sets and Maps -------------------------------------------------------*) + +let compare_comparable + : type a. a comparable_ty -> a -> a -> int + = fun kind x y -> match kind with + | String_key _ -> Compare.String.compare x y + | Bool_key _ -> Compare.Bool.compare x y + | Mutez_key _ -> Tez.compare x y + | Key_hash_key _ -> Signature.Public_key_hash.compare x y + | Int_key _ -> + let res = (Script_int.compare x y) in + if Compare.Int.(res = 0) then 0 + else if Compare.Int.(res > 0) then 1 + else -1 + | Nat_key _ -> + let res = (Script_int.compare x y) in + if Compare.Int.(res = 0) then 0 + else if Compare.Int.(res > 0) then 1 + else -1 + | Timestamp_key _ -> Script_timestamp.compare x y + | Address_key _ -> Contract.compare x y + | Bytes_key _ -> MBytes.compare x y + +let empty_set + : type a. a comparable_ty -> a set + = fun ty -> + let module OPS = Set.Make (struct + type t = a + let compare = compare_comparable ty + end) in + (module struct + type elt = a + module OPS = OPS + let boxed = OPS.empty + let size = 0 + end) + +let set_update + : type a. a -> bool -> a set -> a set + = fun v b (module Box) -> + (module struct + type elt = a + module OPS = Box.OPS + let boxed = + if b + then Box.OPS.add v Box.boxed + else Box.OPS.remove v Box.boxed + let size = + let mem = Box.OPS.mem v Box.boxed in + if mem + then if b then Box.size else Box.size - 1 + else if b then Box.size + 1 else Box.size + end) + +let set_mem + : type elt. elt -> elt set -> bool + = fun v (module Box) -> + Box.OPS.mem v Box.boxed + +let set_fold + : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc + = fun f (module Box) -> + Box.OPS.fold f Box.boxed + +let set_size + : type elt. elt set -> Script_int.n Script_int.num = + fun (module Box) -> + Script_int.(abs (of_int Box.size)) + +let map_key_ty + : type a b. (a, b) map -> a comparable_ty + = fun (module Box) -> Box.key_ty + +let empty_map + : type a b. a comparable_ty -> (a, b) map + = fun ty -> + let module OPS = Map.Make (struct + type t = a + let compare = compare_comparable ty + end) in + (module struct + type key = a + type value = b + let key_ty = ty + module OPS = OPS + let boxed = (OPS.empty, 0) + end) + +let map_get + : type key value. key -> (key, value) map -> value option + = fun k (module Box) -> + Box.OPS.find_opt k (fst Box.boxed) + +let map_update + : type a b. a -> b option -> (a, b) map -> (a, b) map + = fun k v (module Box) -> + (module struct + type key = a + type value = b + let key_ty = Box.key_ty + module OPS = Box.OPS + let boxed = + let (map, size) = Box.boxed in + let contains = Box.OPS.mem k map in + match v with + | Some v -> (Box.OPS.add k v map, size + if contains then 0 else 1) + | None -> (Box.OPS.remove k map, size - if contains then 1 else 0) + end) + +let map_set + : type a b. a -> b -> (a, b) map -> (a, b) map + = fun k v (module Box) -> + (module struct + type key = a + type value = b + let key_ty = Box.key_ty + module OPS = Box.OPS + let boxed = + let (map, size) = Box.boxed in + (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1) + end) + +let map_mem + : type key value. key -> (key, value) map -> bool + = fun k (module Box) -> + Box.OPS.mem k (fst Box.boxed) + +let map_fold + : type key value acc. (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc + = fun f (module Box) -> + Box.OPS.fold f (fst Box.boxed) + +let map_size + : type key value. (key, value) map -> Script_int.n Script_int.num = + fun (module Box) -> + Script_int.(abs (of_int (snd Box.boxed))) + +(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) + +let ty_of_comparable_ty + : type a. a comparable_ty -> a ty + = function + | Int_key tname -> Int_t tname + | Nat_key tname -> Nat_t tname + | String_key tname -> String_t tname + | Bytes_key tname -> Bytes_t tname + | Mutez_key tname -> Mutez_t tname + | Bool_key tname -> Bool_t tname + | Key_hash_key tname -> Key_hash_t tname + | Timestamp_key tname -> Timestamp_t tname + | Address_key tname -> Address_t tname + +let unparse_comparable_ty + : type a. a comparable_ty -> Script.node + = function + | Int_key tname -> Prim (-1, T_int, [], unparse_type_annot tname) + | Nat_key tname -> Prim (-1, T_nat, [], unparse_type_annot tname) + | String_key tname -> Prim (-1, T_string, [], unparse_type_annot tname) + | Bytes_key tname -> Prim (-1, T_bytes, [], unparse_type_annot tname) + | Mutez_key tname -> Prim (-1, T_mutez, [], unparse_type_annot tname) + | Bool_key tname -> Prim (-1, T_bool, [], unparse_type_annot tname) + | Key_hash_key tname -> Prim (-1, T_key_hash, [], unparse_type_annot tname) + | Timestamp_key tname -> Prim (-1, T_timestamp, [], unparse_type_annot tname) + | Address_key tname -> Prim (-1, T_address, [], unparse_type_annot tname) + +let add_field_annot a var = function + | Prim (loc, prim, args, annots) -> + Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var ) + | expr -> expr + +let rec unparse_ty_no_lwt + : type a. context -> a ty -> (Script.node * context) tzresult + = fun ctxt ty -> + Gas.consume ctxt Unparse_costs.cycle >>? fun ctxt -> + let return ctxt (name, args, annot) = + let result = Prim (-1, name, args, annot) in + Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot) >>? fun ctxt -> + ok (result, ctxt) in + match ty with + | Unit_t tname -> return ctxt (T_unit, [], unparse_type_annot tname) + | Int_t tname -> return ctxt (T_int, [], unparse_type_annot tname) + | Nat_t tname -> return ctxt (T_nat, [], unparse_type_annot tname) + | String_t tname -> return ctxt (T_string, [], unparse_type_annot tname) + | Bytes_t tname -> return ctxt (T_bytes, [], unparse_type_annot tname) + | Mutez_t tname -> return ctxt (T_mutez, [], unparse_type_annot tname) + | Bool_t tname -> return ctxt (T_bool, [], unparse_type_annot tname) + | Key_hash_t tname -> return ctxt (T_key_hash, [], unparse_type_annot tname) + | Key_t tname -> return ctxt (T_key, [], unparse_type_annot tname) + | Timestamp_t tname -> return ctxt (T_timestamp, [], unparse_type_annot tname) + | Address_t tname -> return ctxt (T_address, [], unparse_type_annot tname) + | Signature_t tname -> return ctxt (T_signature, [], unparse_type_annot tname) + | Operation_t tname -> return ctxt (T_operation, [], unparse_type_annot tname) + | Contract_t (ut, tname) -> + unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> + return ctxt (T_contract, [ t ], unparse_type_annot tname) + | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) -> + let annot = unparse_type_annot tname in + unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> + let tl = add_field_annot l_field l_var utl in + unparse_ty_no_lwt ctxt utr >>? fun (utr, ctxt) -> + let tr = add_field_annot r_field r_var utr in + return ctxt (T_pair, [ tl; tr ], annot) + | Union_t ((utl, l_field), (utr, r_field), tname) -> + let annot = unparse_type_annot tname in + unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> + let tl = add_field_annot l_field None utl in + unparse_ty_no_lwt ctxt utr >>? fun (utr, ctxt) -> + let tr = add_field_annot r_field None utr in + return ctxt (T_or, [ tl; tr ], annot) + | Lambda_t (uta, utr, tname) -> + unparse_ty_no_lwt ctxt uta >>? fun (ta, ctxt) -> + unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> + return ctxt (T_lambda, [ ta; tr ], unparse_type_annot tname) + | Option_t ((ut, some_field), _none_field, tname) -> + let annot = unparse_type_annot tname in + unparse_ty_no_lwt ctxt ut >>? fun (ut, ctxt) -> + let t = add_field_annot some_field None ut in + return ctxt (T_option, [ t ], annot) + | List_t (ut, tname) -> + unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> + return ctxt (T_list, [ t ], unparse_type_annot tname) + | Set_t (ut, tname) -> + let t = unparse_comparable_ty ut in + return ctxt (T_set, [ t ], unparse_type_annot tname) + | Map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> + return ctxt (T_map, [ ta; tr ], unparse_type_annot tname) + | Big_map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> + return ctxt (T_big_map, [ ta; tr ], unparse_type_annot tname) + +let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty) + +let rec strip_var_annots = function + | Int _ | String _ | Bytes _ as atom -> atom + | Seq (loc, args) -> Seq (loc, List.map strip_var_annots args) + | Prim (loc, name, args, annots) -> + let not_var_annot s = Compare.Char.(String.get s 0 <> '@') in + let annots = List.filter not_var_annot annots in + Prim (loc, name, List.map strip_var_annots args, annots) + +let serialize_ty_for_error ctxt ty = + unparse_ty_no_lwt ctxt ty |> + record_trace Cannot_serialize_error >|? fun (ty, ctxt) -> + strip_locations (strip_var_annots ty), ctxt + +let rec unparse_stack + : type a. context -> a stack_ty -> ((Script.expr * Script.annot) list * context) tzresult Lwt.t + = fun ctxt -> function + | Empty_t -> return ([], ctxt) + | Item_t (ty, rest, annot) -> + unparse_ty ctxt ty >>=? fun (uty, ctxt) -> + unparse_stack ctxt rest >>=? fun (urest, ctxt) -> + return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt) + +let serialize_stack_for_error ctxt stack_ty = + trace Cannot_serialize_error (unparse_stack ctxt stack_ty) + +let name_of_ty + : type a. a ty -> type_annot option + = function + | Unit_t tname -> tname + | Int_t tname -> tname + | Nat_t tname -> tname + | String_t tname -> tname + | Bytes_t tname -> tname + | Mutez_t tname -> tname + | Bool_t tname -> tname + | Key_hash_t tname -> tname + | Key_t tname -> tname + | Timestamp_t tname -> tname + | Address_t tname -> tname + | Signature_t tname -> tname + | Operation_t tname -> tname + | Contract_t (_, tname) -> tname + | Pair_t (_, _, tname) -> tname + | Union_t (_, _, tname) -> tname + | Lambda_t (_, _, tname) -> tname + | Option_t (_, _, tname) -> tname + | List_t (_, tname) -> tname + | Set_t (_, tname) -> tname + | Map_t (_, _, tname) -> tname + | Big_map_t (_, _, tname) -> tname + +(* ---- Equality witnesses --------------------------------------------------*) + +type ('ta, 'tb) eq = Eq : ('same, 'same) eq + +let comparable_ty_eq + : type ta tb. + context -> + ta comparable_ty -> tb comparable_ty -> + (ta comparable_ty, tb comparable_ty) eq tzresult + = fun ctxt ta tb -> match ta, tb with + | Int_key _, Int_key _ -> Ok Eq + | Nat_key _, Nat_key _ -> Ok Eq + | String_key _, String_key _ -> Ok Eq + | Bytes_key _, Bytes_key _ -> Ok Eq + | Mutez_key _, Mutez_key _ -> Ok Eq + | Bool_key _, Bool_key _ -> Ok Eq + | Key_hash_key _, Key_hash_key _ -> Ok Eq + | Timestamp_key _, Timestamp_key _ -> Ok Eq + | Address_key _, Address_key _ -> Ok Eq + | _, _ -> + serialize_ty_for_error ctxt (ty_of_comparable_ty ta) >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt (ty_of_comparable_ty tb) >>? fun (tb, _ctxt) -> + error (Inconsistent_types (ta, tb)) + +let record_inconsistent ctxt ta tb = + record_trace_eval (fun () -> + serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> + Inconsistent_types (ta, tb)) + +let record_inconsistent_type_annotations ctxt loc ta tb = + record_trace_eval (fun () -> + serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> + Inconsistent_type_annotations (loc, ta, tb)) + +let rec ty_eq + : type ta tb. context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult + = fun ctxt ta tb -> + let ok (eq : (ta ty, tb ty) eq) ctxt nb_args : + ((ta ty, tb ty) eq * context) tzresult = + Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args)) >>? fun ctxt -> + Ok (eq, ctxt) in + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + match ta, tb with + | Unit_t _, Unit_t _ -> ok Eq ctxt 0 + | Int_t _, Int_t _ -> ok Eq ctxt 0 + | Nat_t _, Nat_t _ -> ok Eq ctxt 0 + | Key_t _, Key_t _ -> ok Eq ctxt 0 + | Key_hash_t _, Key_hash_t _ -> ok Eq ctxt 0 + | String_t _, String_t _ -> ok Eq ctxt 0 + | Bytes_t _, Bytes_t _ -> ok Eq ctxt 0 + | Signature_t _, Signature_t _ -> ok Eq ctxt 0 + | Mutez_t _, Mutez_t _ -> ok Eq ctxt 0 + | Timestamp_t _, Timestamp_t _ -> ok Eq ctxt 0 + | Address_t _, Address_t _ -> ok Eq ctxt 0 + | Bool_t _, Bool_t _ -> ok Eq ctxt 0 + | Operation_t _, Operation_t _ -> ok Eq ctxt 0 + | Map_t (tal, tar, _), Map_t (tbl, tbr, _) -> + (comparable_ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> + (ok Eq ctxt 2)) |> + record_inconsistent ctxt ta tb + | Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _) -> + (comparable_ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> + (ok Eq ctxt 2)) |> + record_inconsistent ctxt ta tb + | Set_t (ea, _), Set_t (eb, _) -> + (comparable_ty_eq ctxt ea eb >>? fun Eq -> + (ok Eq ctxt 1)) |> + record_inconsistent ctxt ta tb + | Pair_t ((tal, _, _), (tar, _, _), _), + Pair_t ((tbl, _, _), (tbr, _, _), _) -> + (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> + (ok Eq ctxt 2)) |> + record_inconsistent ctxt ta tb + | Union_t ((tal, _), (tar, _), _), Union_t ((tbl, _), (tbr, _), _) -> + (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> + (ok Eq ctxt 2)) |> + record_inconsistent ctxt ta tb + | Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _) -> + (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> + (ok Eq ctxt 2)) |> + record_inconsistent ctxt ta tb + | Contract_t (tal, _), Contract_t (tbl, _) -> + (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> + (ok Eq ctxt 1)) |> + record_inconsistent ctxt ta tb + | Option_t ((tva, _), _, _), Option_t ((tvb, _), _, _) -> + (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> + (ok Eq ctxt 1)) |> + record_inconsistent ctxt ta tb + | List_t (tva, _), List_t (tvb, _) -> + (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> + (ok Eq ctxt 1)) |> + record_inconsistent ctxt ta tb + | _, _ -> + serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb >>? fun (tb, _ctxt) -> + error (Inconsistent_types (ta, tb)) + +let rec stack_ty_eq + : type ta tb. context -> int -> ta stack_ty -> tb stack_ty -> + ((ta stack_ty, tb stack_ty) eq * context) tzresult + = fun ctxt lvl ta tb -> + match ta, tb with + | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> + ty_eq ctxt tva tvb |> + record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) -> + stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) -> + (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult) + | Empty_t, Empty_t -> Ok (Eq, ctxt) + | _, _ -> error Bad_stack_length + +let merge_comparable_types + : type ta. ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult + = fun ta tb -> + match ta, tb with + | Int_key annot_a, Int_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Int_key annot + | Nat_key annot_a, Nat_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Nat_key annot + | String_key annot_a, String_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + String_key annot + | Bytes_key annot_a, Bytes_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Bytes_key annot + | Mutez_key annot_a, Mutez_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Mutez_key annot + | Bool_key annot_a, Bool_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Bool_key annot + | Key_hash_key annot_a, Key_hash_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Key_hash_key annot + | Timestamp_key annot_a, Timestamp_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Timestamp_key annot + | Address_key annot_a, Address_key annot_b -> + merge_type_annot annot_a annot_b >|? fun annot -> + Address_key annot + | _, _ -> assert false (* FIXME: fix injectivity of some types *) + +let rec strip_annotations = function + | (Int (_,_) as i) -> i + | (String (_,_) as s) -> s + | (Bytes (_,_) as s) -> s + | Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, []) + | Seq (loc, items) -> Seq (loc, List.map strip_annotations items) + +let merge_types : + type b. context -> Script.location -> b ty -> b ty -> (b ty * context) tzresult = + let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult + = fun ctxt ty1 ty2 -> + match ty1, ty2 with + | Unit_t tn1, Unit_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Unit_t tname, ctxt + | Int_t tn1, Int_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Int_t tname, ctxt + | Nat_t tn1, Nat_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Nat_t tname, ctxt + | Key_t tn1, Key_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Key_t tname, ctxt + | Key_hash_t tn1, Key_hash_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Key_hash_t tname, ctxt + | String_t tn1, String_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + String_t tname, ctxt + | Bytes_t tn1, Bytes_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Bytes_t tname, ctxt + | Signature_t tn1, Signature_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Signature_t tname, ctxt + | Mutez_t tn1, Mutez_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Mutez_t tname, ctxt + | Timestamp_t tn1, Timestamp_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Timestamp_t tname, ctxt + | Address_t tn1, Address_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Address_t tname, ctxt + | Bool_t tn1, Bool_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Bool_t tname, ctxt + | Operation_t tn1, Operation_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Operation_t tname, ctxt + | Map_t (tal, tar, tn1), Map_t (tbl, tbr, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help ctxt tar tbr >>? fun (value, ctxt) -> + ty_eq ctxt tar value >>? fun (Eq, ctxt) -> + merge_comparable_types tal tbl >|? fun tk -> + Map_t (tk, value, tname), ctxt + | Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help ctxt tar tbr >>? fun (value, ctxt) -> + ty_eq ctxt tar value >>? fun (Eq, ctxt) -> + merge_comparable_types tal tbl >|? fun tk -> + Big_map_t (tk, value, tname), ctxt + | Set_t (ea, tn1), Set_t (eb, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_comparable_types ea eb >|? fun e -> + Set_t (e, tname), ctxt + | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1), + Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_field_annot l_field1 l_field2 >>? fun l_field -> + merge_field_annot r_field1 r_field2 >>? fun r_field -> + let l_var = merge_var_annot l_var1 l_var2 in + let r_var = merge_var_annot r_var1 r_var2 in + help ctxt tal tbl >>? fun (left_ty, ctxt) -> + help ctxt tar tbr >|? fun (right_ty, ctxt) -> + Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname), + ctxt + | Union_t ((tal, tal_annot), (tar, tar_annot), tn1), + Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_field_annot tal_annot tbl_annot >>? fun left_annot -> + merge_field_annot tar_annot tbr_annot >>? fun right_annot -> + help ctxt tal tbl >>? fun (left_ty, ctxt) -> + help ctxt tar tbr >|? fun (right_ty, ctxt) -> + Union_t ((left_ty, left_annot), (right_ty, right_annot), tname), + ctxt + | Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help ctxt tal tbl >>? fun (left_ty, ctxt) -> + help ctxt tar tbr >|? fun (right_ty, ctxt) -> + Lambda_t (left_ty, right_ty, tname), ctxt + | Contract_t (tal, tn1), Contract_t (tbl, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help ctxt tal tbl >|? fun (arg_ty, ctxt) -> + Contract_t (arg_ty, tname), ctxt + | Option_t ((tva, some_annot_a), none_annot_a, tn1), + Option_t ((tvb, some_annot_b), none_annot_b, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_field_annot some_annot_a some_annot_b >>? fun some_annot -> + merge_field_annot none_annot_a none_annot_b >>? fun none_annot -> + help ctxt tva tvb >|? fun (ty, ctxt) -> + Option_t ((ty, some_annot), none_annot, tname), ctxt + | List_t (tva, tn1), List_t (tvb, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help ctxt tva tvb >|? fun (ty, ctxt) -> + List_t (ty, tname), ctxt + | _, _ -> assert false + in (fun ctxt loc ty1 ty2 -> + record_inconsistent_type_annotations ctxt loc ty1 ty2 + (help ctxt ty1 ty2)) + +let merge_stacks + : type ta. Script.location -> context -> ta stack_ty -> ta stack_ty -> + (ta stack_ty * context) tzresult + = fun loc -> + let rec help : type a. context -> a stack_ty -> a stack_ty -> + (a stack_ty * context) tzresult + = fun ctxt stack1 stack2 -> + match stack1, stack2 with + | Empty_t, Empty_t -> ok (Empty_t, ctxt) + | Item_t (ty1, rest1, annot1), + Item_t (ty2, rest2, annot2) -> + let annot = merge_var_annot annot1 annot2 in + merge_types ctxt loc ty1 ty2 >>? fun (ty, ctxt) -> + help ctxt rest1 rest2 >|? fun (rest, ctxt) -> + Item_t (ty, rest, annot), ctxt + in help + +(* ---- Type checker results -------------------------------------------------*) + +type 'bef judgement = + | Typed : ('bef, 'aft) descr -> 'bef judgement + | Failed : { descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr } -> 'bef judgement + +(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) + +type ('t, 'f, 'b) branch = + { branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr } [@@unboxed] + + +let merge_branches + : type bef a b. context -> int -> a judgement -> b judgement -> + (a, b, bef) branch -> + (bef judgement * context) tzresult Lwt.t + = fun ctxt loc btr bfr { branch } -> + match btr, bfr with + | Typed ({ aft = aftbt ; _ } as dbt), Typed ({ aft = aftbf ; _ } as dbf) -> + let unmatched_branches () = + serialize_stack_for_error ctxt aftbt >>=? fun (aftbt, ctxt) -> + serialize_stack_for_error ctxt aftbf >>|? fun (aftbf, _ctxt) -> + Unmatched_branches (loc, aftbt, aftbf) in + trace_eval unmatched_branches + (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) -> + Lwt.return (merge_stacks loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> + return ( + Typed (branch {dbt with aft=merged_stack} {dbf with aft=merged_stack}), + ctxt)) + | Failed { descr = descrt }, Failed { descr = descrf } -> + let descr ret = + branch (descrt ret) (descrf ret) in + return (Failed { descr }, ctxt) + | Typed dbt, Failed { descr = descrf } -> + return (Typed (branch dbt (descrf dbt.aft)), ctxt) + | Failed { descr = descrt }, Typed dbf -> + return (Typed (branch (descrt dbf.aft) dbf), ctxt) + +let rec parse_comparable_ty + : context -> Script.node -> (ex_comparable_ty * context) tzresult + = fun ctxt ty -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >>? fun ctxt -> + match ty with + | Prim (loc, T_int, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Int_key tname ), ctxt + | Prim (loc, T_nat, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Nat_key tname ), ctxt + | Prim (loc, T_string, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( String_key tname ), ctxt + | Prim (loc, T_bytes, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Bytes_key tname ), ctxt + | Prim (loc, T_mutez, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Mutez_key tname ), ctxt + | Prim (loc, T_bool, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Bool_key tname ), ctxt + | Prim (loc, T_key_hash, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Key_hash_key tname ), ctxt + | Prim (loc, T_timestamp, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Timestamp_key tname ), ctxt + | Prim (loc, T_address, [], annot) -> + parse_type_annot loc annot >|? fun tname -> + Ex_comparable_ty ( Address_key tname ), ctxt + | Prim (loc, (T_int | T_nat + | T_string | T_mutez | T_bool + | T_key | T_address | T_timestamp as prim), l, _) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, (T_pair | T_or | T_set | T_map + | T_list | T_option | T_lambda + | T_unit | T_signature | T_contract), _, _) -> + error (Comparable_type_expected (loc, Micheline.strip_locations ty)) + | expr -> + error @@ unexpected expr [] Type_namespace + [ T_int ; T_nat ; + T_string ; T_mutez ; T_bool ; + T_key ; T_key_hash ; T_timestamp ] + +and parse_ty : + context -> + allow_big_map: bool -> + allow_operation: bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~allow_big_map ~allow_operation node -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + match node with + | Prim (loc, T_unit, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Unit_t ty_name), ctxt + | Prim (loc, T_int, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Int_t ty_name), ctxt + | Prim (loc, T_nat, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Nat_t ty_name), ctxt + | Prim (loc, T_string, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (String_t ty_name), ctxt + | Prim (loc, T_bytes, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Bytes_t ty_name), ctxt + | Prim (loc, T_mutez, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Mutez_t ty_name), ctxt + | Prim (loc, T_bool, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Bool_t ty_name), ctxt + | Prim (loc, T_key, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Key_t ty_name), ctxt + | Prim (loc, T_key_hash, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Key_hash_t ty_name), ctxt + | Prim (loc, T_timestamp, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Timestamp_t ty_name), ctxt + | Prim (loc, T_address, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Address_t ty_name), ctxt + | Prim (loc, T_signature, [], annot) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Signature_t ty_name), ctxt + | Prim (loc, T_operation, [], annot) -> + if allow_operation then + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Operation_t ty_name), ctxt + else + error (Unexpected_operation loc) + | Prim (loc, T_contract, [ utl ], annot) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false utl >>? fun (Ex_ty tl, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> + Ex_ty (Contract_t (tl, ty_name)), ctxt + | Prim (loc, T_pair, [ utl; utr ], annot) -> + extract_field_annot utl >>? fun (utl, left_field) -> + extract_field_annot utr >>? fun (utr, right_field) -> + parse_ty ctxt ~allow_big_map ~allow_operation utl >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name)), ctxt + | Prim (loc, T_or, [ utl; utr ], annot) -> + extract_field_annot utl >>? fun (utl, left_constr) -> + extract_field_annot utr >>? fun (utr, right_constr) -> + parse_ty ctxt ~allow_big_map ~allow_operation utl >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name)), ctxt + | Prim (loc, T_lambda, [ uta; utr ], annot) -> + parse_ty ctxt ~allow_big_map:true ~allow_operation:true uta >>? fun (Ex_ty ta, ctxt) -> + parse_ty ctxt ~allow_big_map:true ~allow_operation:true utr >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt + | Prim (loc, T_option, [ ut ], annot) -> + extract_field_annot ut >>? fun (ut, some_constr) -> + parse_ty ctxt ~allow_big_map ~allow_operation ut >>? fun (Ex_ty t, ctxt) -> + parse_composed_type_annot loc annot >>? fun (ty_name, none_constr, _) -> + Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + Ex_ty (Option_t ((t, some_constr), none_constr, ty_name)), ctxt + | Prim (loc, T_list, [ ut ], annot) -> + parse_ty ctxt ~allow_big_map ~allow_operation ut >>? fun (Ex_ty t, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> + Ex_ty (List_t (t, ty_name)), ctxt + | Prim (loc, T_set, [ ut ], annot) -> + parse_comparable_ty ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> + Ex_ty (Set_t (t, ty_name)), ctxt + | Prim (loc, T_map, [ uta; utr ], annot) -> + parse_comparable_ty ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> + parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + Ex_ty (Map_t (ta, tr, ty_name)), ctxt + | Prim (loc, T_big_map, args, annot) + when allow_big_map -> + parse_big_map_ty ctxt loc args annot >>? fun (big_map_ty, ctxt) -> + Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> + big_map_ty, ctxt + | Prim (loc, T_big_map, _, _) -> + error (Unexpected_big_map loc) + | Prim (loc, (T_unit | T_signature + | T_int | T_nat + | T_string | T_bytes | T_mutez | T_bool + | T_key | T_key_hash + | T_timestamp | T_address as prim), l, _) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, (T_set | T_list | T_option as prim), l, _) -> + error (Invalid_arity (loc, prim, 1, List.length l)) + | Prim (loc, (T_pair | T_or | T_map | T_lambda | T_contract as prim), l, _) -> + error (Invalid_arity (loc, prim, 2, List.length l)) + | expr -> + error @@ unexpected expr [] Type_namespace + [ T_pair ; T_or ; T_set ; T_map ; + T_list ; T_option ; T_lambda ; + T_unit ; T_signature ; T_contract ; + T_int ; T_nat ; T_operation ; + T_string ; T_bytes ; T_mutez ; T_bool ; + T_key ; T_key_hash ; T_timestamp ] + +and parse_big_map_ty ctxt big_map_loc args map_annot = + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + begin match args with + | [ key_ty ; value_ty ] -> + parse_comparable_ty ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false value_ty + >>? fun (Ex_ty value_ty, ctxt) -> + parse_type_annot big_map_loc map_annot >|? fun map_name -> + let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in + Ex_ty big_map_ty, ctxt + | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) + end + +and parse_storage_ty : + context -> Script.node -> (ex_ty * context) tzresult + = fun ctxt node -> + match node with + | Prim (loc, T_pair, + [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], + storage_annot) -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + parse_big_map_ty ctxt big_map_loc args map_annot >>? fun (Ex_ty big_map_ty, ctxt) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false remaining_storage + >>? fun (Ex_ty remaining_storage, ctxt) -> + parse_composed_type_annot loc storage_annot + >>? fun (ty_name, map_field, storage_field) -> + Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> + Ex_ty (Pair_t ((big_map_ty, map_field, None), + (remaining_storage, storage_field, None), + ty_name)), + ctxt + | _ -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false node + +let check_no_big_map_or_operation loc root = + let rec check : type t. t ty -> unit tzresult = function + | Big_map_t _ -> error (Unexpected_big_map loc) + | Operation_t _ -> error (Unexpected_operation loc) + | Unit_t _ -> ok () + | Int_t _ -> ok () + | Nat_t _ -> ok () + | Signature_t _ -> ok () + | String_t _ -> ok () + | Bytes_t _ -> ok () + | Mutez_t _ -> ok () + | Key_hash_t _ -> ok () + | Key_t _ -> ok () + | Timestamp_t _ -> ok () + | Address_t _ -> ok () + | Bool_t _ -> ok () + | Pair_t ((l_ty, _, _), (r_ty, _, _), _) -> + check l_ty >>? fun () -> check r_ty + | Union_t ((l_ty, _), (r_ty, _), _) -> + check l_ty >>? fun () -> check r_ty + | Option_t ((v_ty, _), _, _) -> check v_ty + | List_t (elt_ty, _) -> check elt_ty + | Set_t (_, _) -> ok () + | Map_t (_, elt_ty, _) -> check elt_ty + | Lambda_t (_l_ty, _r_ty, _) -> ok () + | Contract_t (_, _) -> ok () in + check root + +type ex_script = Ex_script : ('a, 'c) script -> ex_script + +(* Lwt versions *) +let parse_var_annot loc ?default annot = + Lwt.return (parse_var_annot loc ?default annot) +let parse_constr_annot loc ?if_special_first ?if_special_second annot = + Lwt.return (parse_constr_annot loc ?if_special_first ?if_special_second annot) +let parse_two_var_annot loc annot = + Lwt.return (parse_two_var_annot loc annot) +let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value_annot = + Lwt.return (parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value_annot) +let parse_var_type_annot loc annot = + Lwt.return (parse_var_type_annot loc annot) + +let rec parse_data + : type a. + ?type_logger: type_logger -> + context -> a ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ty script_data -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + let error () = + Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) -> + Invalid_constant (location script_data, strip_locations script_data, ty) in + let traced body = + trace_eval error body in + let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper = + let length = List.length items in + fold_left_s + (fun (last_value, map, ctxt) item -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length)) >>=? fun ctxt -> + match item with + | Prim (_, D_Elt, [ k; v ], _) -> + parse_comparable_data ?type_logger ctxt key_type k >>=? fun (k, ctxt) -> + parse_data ?type_logger ctxt value_type v >>=? fun (v, ctxt) -> + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable key_type value k)) + then + if Compare.Int.(0 = (compare_comparable key_type value k)) + then fail (Duplicate_map_keys (loc, strip_locations expr)) + else fail (Unordered_map_keys (loc, strip_locations expr)) + else return_unit + | None -> return_unit + end >>=? fun () -> + return (Some k, map_update k (Some (item_wrapper v)) map, ctxt) + | Prim (loc, D_Elt, l, _) -> + fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + fail @@ Invalid_primitive (loc, [ D_Elt ], name) + | Int _ | String _ | Bytes _ | Seq _ -> + error () >>=? fail) + (None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) -> + (items, ctxt) in + match ty, script_data with + (* Unit *) + | Unit_t ty_name, Prim (loc, D_Unit, [], annot) -> + check_const_type_annot loc annot ty_name [] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.unit) >>|? fun ctxt -> + ((() : a), ctxt) + | Unit_t _, Prim (loc, D_Unit, l, _) -> + traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l))) + | Unit_t _, expr -> + traced (fail (unexpected expr [] Constant_namespace [ D_Unit ])) + (* Booleans *) + | Bool_t ty_name, Prim (loc, D_True, [], annot) -> + check_const_type_annot loc annot ty_name [] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> + (true, ctxt) + | Bool_t ty_name, Prim (loc, D_False, [], annot) -> + check_const_type_annot loc annot ty_name [] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> + (false, ctxt) + | Bool_t _, Prim (loc, (D_True | D_False as c), l, _) -> + traced (fail (Invalid_arity (loc, c, 0, List.length l))) + | Bool_t _, expr -> + traced (fail (unexpected expr [] Constant_namespace [ D_True ; D_False ])) + (* Strings *) + | String_t _, String (_, v) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v))) >>=? fun ctxt -> + let rec check_printable_ascii i = + if Compare.Int.(i < 0) then true + else match String.get v i with + | '\n' | '\x20'..'\x7E' -> check_printable_ascii (i - 1) + | _ -> false in + if check_printable_ascii (String.length v - 1) then + return (v, ctxt) + else + error () >>=? fail + | String_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) + (* Byte sequences *) + | Bytes_t _, Bytes (_, v) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v))) >>=? fun ctxt -> + return (v, ctxt) + | Bytes_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Bytes_kind ], kind expr))) + (* Integers *) + | Int_t _, Int (_, v) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) >>=? fun ctxt -> + return (Script_int.of_zint v, ctxt) + | Nat_t _, Int (_, v) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) >>=? fun ctxt -> + let v = Script_int.of_zint v in + if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then + return (Script_int.abs v, ctxt) + else + error () >>=? fail + | Int_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) + | Nat_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) + (* Tez amounts *) + | Mutez_t _, Int (_, v) -> + Lwt.return ( + Gas.consume ctxt Typecheck_costs.tez >>? fun ctxt -> + Gas.consume ctxt Michelson_v1_gas.Cost_of.z_to_int64 + ) >>=? fun ctxt -> + begin try + match Tez.of_mutez (Z.to_int64 v) with + | None -> raise Exit + | Some tez -> return (tez, ctxt) + with _ -> + error () >>=? fail + end + | Mutez_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) + (* Timestamps *) + | Timestamp_t _, (Int (_, v)) (* As unparsed with [Optimized] or out of bounds [Readable]. *) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) >>=? fun ctxt -> + return (Script_timestamp.of_zint v, ctxt) + | Timestamp_t _, String (_, s) (* As unparsed with [Redable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt -> + begin match Script_timestamp.of_string s with + | Some v -> return (v, ctxt) + | None -> error () >>=? fail + end + | Timestamp_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr))) + (* IDs *) + | Key_t _, Bytes (_, bytes) -> (* As unparsed with [Optimized]. *) + Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> + begin match Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes with + | Some k -> return (k, ctxt) + | None -> error () >>=? fail + end + | Key_t _, String (_, s) -> (* As unparsed with [Readable]. *) + Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> + begin match Signature.Public_key.of_b58check_opt s with + | Some k -> return (k, ctxt) + | None -> error () >>=? fail + end + | Key_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) + | Key_hash_t _, Bytes (_, bytes) -> (* As unparsed with [Optimized]. *) + Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> + begin + match Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes with + | Some k -> return (k, ctxt) + | None -> error () >>=? fail + end + | Key_hash_t _, String (_, s) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> + begin match Signature.Public_key_hash.of_b58check_opt s with + | Some k -> return (k, ctxt) + | None -> error () >>=? fail + end + | Key_hash_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) + (* Signatures *) + | Signature_t _, Bytes (_, bytes) (* As unparsed with [Optimized]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> + begin match Data_encoding.Binary.of_bytes Signature.encoding bytes with + | Some k -> return (k, ctxt) + | None -> error () >>=? fail + end + | Signature_t _, String (_, s) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> + begin match Signature.of_b58check_opt s with + | Some s -> return (s, ctxt) + | None -> error () >>=? fail + end + | Signature_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) + (* Operations *) + | Operation_t _, _ -> + (* operations cannot appear in parameters or storage, + the protocol should never parse the bytes of an operation *) + assert false + (* Addresses *) + | Address_t _, Bytes (_, bytes) (* As unparsed with [O[ptimized]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> + begin + match Data_encoding.Binary.of_bytes Contract.encoding bytes with + | Some c -> return (c, ctxt) + | None -> error () >>=? fail + end + | Address_t _, String (_, s) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> + traced (Lwt.return (Contract.of_b58check s)) >>=? fun c -> + return (c, ctxt) + | Address_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) + (* Contracts *) + | Contract_t (ty, _), Bytes (loc, bytes) (* As unparsed with [Optimized]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> + begin + match Data_encoding.Binary.of_bytes Contract.encoding bytes with + | Some c -> + traced (parse_contract ctxt loc ty c) >>=? fun (ctxt, _) -> + return ((ty, c), ctxt) + | None -> error () >>=? fail + end + | Contract_t (ty, _), String (loc, s) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> + traced @@ + Lwt.return (Contract.of_b58check s) >>=? fun c -> + parse_contract ctxt loc ty c >>=? fun (ctxt, _) -> + return ((ty, c), ctxt) + | Contract_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) + (* Pairs *) + | Pair_t ((ta, af, _), (tb, bf, _), ty_name), Prim (loc, D_Pair, [ va; vb ], annot) -> + check_const_type_annot loc annot ty_name [af; bf] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt -> + traced @@ + parse_data ?type_logger ctxt ta va >>=? fun (va, ctxt) -> + parse_data ?type_logger ctxt tb vb >>=? fun (vb, ctxt) -> + return ((va, vb), ctxt) + | Pair_t _, Prim (loc, D_Pair, l, _) -> + fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + | Pair_t _, expr -> + traced (fail (unexpected expr [] Constant_namespace [ D_Pair ])) + (* Unions *) + | Union_t ((tl, lconstr), _, ty_name), Prim (loc, D_Left, [ v ], annot) -> + check_const_type_annot loc annot ty_name [lconstr]>>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> + traced @@ + parse_data ?type_logger ctxt tl v >>=? fun (v, ctxt) -> + return (L v, ctxt) + | Union_t _, Prim (loc, D_Left, l, _) -> + fail @@ Invalid_arity (loc, D_Left, 1, List.length l) + | Union_t (_, (tr, rconstr), ty_name), Prim (loc, D_Right, [ v ], annot) -> + check_const_type_annot loc annot ty_name [rconstr] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> + traced @@ + parse_data ?type_logger ctxt tr v >>=? fun (v, ctxt) -> + return (R v, ctxt) + | Union_t _, Prim (loc, D_Right, l, _) -> + fail @@ Invalid_arity (loc, D_Right, 1, List.length l) + | Union_t _, expr -> + traced (fail (unexpected expr [] Constant_namespace [ D_Left ; D_Right ])) + (* Lambdas *) + | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> + traced @@ + parse_returning Lambda ?type_logger ctxt (ta, Some (`Var_annot "@arg")) tr script_instr + | Lambda_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + (* Options *) + | Option_t ((t, some_constr), _, ty_name), Prim (loc, D_Some, [ v ], annot) -> + check_const_type_annot loc annot ty_name [some_constr] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt -> + traced @@ + parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + return (Some v, ctxt) + | Option_t _, Prim (loc, D_Some, l, _) -> + fail @@ Invalid_arity (loc, D_Some, 1, List.length l) + | Option_t (_, none_constr, ty_name), Prim (loc, D_None, [], annot) -> + check_const_type_annot loc annot ty_name [none_constr] >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.none) >>=? fun ctxt -> + return (None, ctxt) + | Option_t _, Prim (loc, D_None, l, _) -> + fail @@ Invalid_arity (loc, D_None, 0, List.length l) + | Option_t _, expr -> + traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) + (* Lists *) + | List_t (t, _ty_name), Seq (_loc, items) -> + traced @@ + fold_right_s + (fun v (rest, ctxt) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) >>=? fun ctxt -> + parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + return ((v :: rest), ctxt)) + items ([], ctxt) + | List_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + (* Sets *) + | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> + let length = List.length vs in + traced @@ + fold_left_s + (fun (last_value, set, ctxt) v -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length)) >>=? fun ctxt -> + parse_comparable_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable t value v)) + then + if Compare.Int.(0 = (compare_comparable t value v)) + then fail (Duplicate_set_values (loc, strip_locations expr)) + else fail (Unordered_set_values (loc, strip_locations expr)) + else return_unit + | None -> return_unit + end >>=? fun () -> + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.set_update v false set)) >>=? fun ctxt -> + return (Some v, set_update v true set, ctxt)) + (None, empty_set t, ctxt) vs >>|? fun (_, set, ctxt) -> + (set, ctxt) + | Set_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + (* Maps *) + | Map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) + | Map_t _, expr -> + traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + | Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> + ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + | Big_map_t (_tk, _tv, _), expr -> + traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + +and parse_comparable_data + : type a. + ?type_logger:type_logger -> + context -> a comparable_ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ty script_data -> + parse_data ?type_logger ctxt (ty_of_comparable_ty ty) script_data + +and parse_returning + : type arg ret. + ?type_logger: type_logger -> + tc_context -> context -> + arg ty * var_annot option -> ret ty -> Script.node -> + ((arg, ret) lambda * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt (arg, arg_annot) ret script_instr -> + parse_instr ?type_logger tc_context ctxt + script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function + | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) -> + trace_eval + (fun () -> + Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_return (loc, stack_ty, ret)) + (Lwt.return (ty_eq ctxt ty ret) >>=? fun (Eq, ctxt) -> + Lwt.return (merge_types ctxt loc ty ret) >>=? fun (_ret, ctxt) -> + return ((Lam (descr, strip_locations script_instr) : (arg, ret) lambda), ctxt)) + | (Typed { loc ; aft = stack_ty ; _ }, ctxt) -> + Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty >>=? fun (stack_ty, _ctxt) -> + fail (Bad_return (loc, stack_ty, ret)) + | (Failed { descr }, ctxt) -> + return ((Lam (descr (Item_t (ret, Empty_t, None)), strip_locations script_instr) + : (arg, ret) lambda), ctxt) + +and parse_instr + : type bef. + ?type_logger: type_logger -> + tc_context -> context -> + Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt script_instr stack_ty -> + let check_item check loc name n m = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_stack (loc, name, m, stack_ty)) @@ + trace (Bad_stack_item n) @@ + Lwt.return check in + let check_item_ty ctxt exp got loc n = + check_item (ty_eq ctxt exp got) loc n in + let log_stack ctxt loc stack_ty aft = + match type_logger, script_instr with + | None, _ + | Some _, (Seq (-1, _) | Int _ | String _ | Bytes _) -> return_unit + | Some log, (Prim _ | Seq _) -> + (* Unparsing for logging done in an unlimited context as this + is used only by the client and not the protocol *) + let ctxt = Gas.set_unlimited ctxt in + unparse_stack ctxt stack_ty >>=? fun (stack_ty, _) -> + unparse_stack ctxt aft >>=? fun (aft, _) -> + log loc stack_ty aft; + return_unit + in + let return : + context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> + match judgement with + | Typed { instr ; loc ; aft ; _ } -> + let maximum_type_size = Constants.michelson_maximum_type_size ctxt in + let type_size = + type_size_of_stack_head aft + ~up_to:(number_of_generated_growing_types instr) in + if Compare.Int.(type_size > maximum_type_size) then + fail (Type_too_large (loc, type_size, maximum_type_size)) + else + return (judgement, ctxt) + | Failed _ -> + return (judgement, ctxt) in + let typed ctxt loc instr aft = + log_stack ctxt loc stack_ty aft >>=? fun () -> + Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr) >>=? fun ctxt -> + return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in + Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle >>=? fun ctxt -> + match script_instr, stack_ty with + (* stack ops *) + | Prim (loc, I_DROP, [], annot), + Item_t (_, rest, _) -> + fail_unexpected_annot loc annot >>=? fun () -> + typed ctxt loc Drop + rest + | Prim (loc, I_DUP, [], annot), + Item_t (v, rest, stack_annot) -> + parse_var_annot loc annot ~default:stack_annot >>=? fun annot -> + typed ctxt loc Dup + (Item_t (v, Item_t (v, rest, stack_annot), annot)) + | Prim (loc, I_SWAP, [], annot), + Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) -> + fail_unexpected_annot loc annot >>=? fun () -> + typed ctxt loc Swap + (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot)) + | Prim (loc, I_PUSH, [ t ; d ], annot), + stack -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false t >>=? fun (Ex_ty t, ctxt) -> + parse_data ?type_logger ctxt t d >>=? fun (v, ctxt) -> + typed ctxt loc (Const v) (Item_t (t, stack, annot)) + | Prim (loc, I_UNIT, [], annot), + stack -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) + (* options *) + | Prim (loc, I_SOME, [], annot), + Item_t (t, rest, stack_annot) -> + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, ty_name, some_field, none_field) -> + typed ctxt loc Cons_some + (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) + | Prim (loc, I_NONE, [ t ], annot), + stack -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true t >>=? fun (Ex_ty t, ctxt) -> + parse_constr_annot loc annot >>=? fun (annot, ty_name, some_field, none_field) -> + typed ctxt loc (Cons_none t) + (Item_t (Option_t ((t, some_field), none_field, ty_name), stack, annot)) + | Prim (loc, I_IF_NONE, [ bt ; bf ], annot), + (Item_t (Option_t ((t, some_field), _none_field, _), rest, option_annot) as bef) -> + check_kind [ Seq_kind ] bt >>=? fun () -> + check_kind [ Seq_kind ] bf >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let annot = gen_access_annot option_annot some_field ~default:default_some_annot in + parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + return ctxt judgement + (* pairs *) + | Prim (loc, I_PAIR, [], annot), + Item_t (a, Item_t (b, rest, snd_annot), fst_annot) -> + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot fst_annot) + ~if_special_second:(var_to_field_annot snd_annot) + >>=? fun (annot, ty_name, l_field, r_field) -> + typed ctxt loc Cons_pair + (Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name), rest, annot)) + | Prim (loc, I_CAR, [], annot), + Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) -> + parse_destr_annot loc annot + ~pair_annot + ~value_annot:a_annot + ~field_name:expected_field_annot + ~default_accessor:default_car_annot + >>=? fun (annot, field_annot) -> + Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> + typed ctxt loc Car (Item_t (a, rest, annot)) + | Prim (loc, I_CDR, [], annot), + Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) -> + parse_destr_annot loc annot + ~pair_annot + ~value_annot:b_annot + ~field_name:expected_field_annot + ~default_accessor:default_cdr_annot + >>=? fun (annot, field_annot) -> + Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> + typed ctxt loc Cdr (Item_t (b, rest, annot)) + (* unions *) + | Prim (loc, I_LEFT, [ tr ], annot), + Item_t (tl, rest, stack_annot) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tr >>=? fun (Ex_ty tr, ctxt) -> + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, tname, l_field, r_field) -> + typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + | Prim (loc, I_RIGHT, [ tl ], annot), + Item_t (tr, rest, stack_annot) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tl >>=? fun (Ex_ty tl, ctxt) -> + parse_constr_annot loc annot + ~if_special_second:(var_to_field_annot stack_annot) + >>=? fun (annot, tname, l_field, r_field) -> + typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + | Prim (loc, I_IF_LEFT, [ bt ; bf ], annot), + (Item_t (Union_t ((tl, l_field), (tr, r_field), _), rest, union_annot) as bef) -> + check_kind [ Seq_kind ] bt >>=? fun () -> + check_kind [ Seq_kind ] bf >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let left_annot = gen_access_annot union_annot l_field ~default:default_left_annot in + let right_annot = gen_access_annot union_annot r_field ~default:default_right_annot in + parse_instr ?type_logger tc_context ctxt bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + return ctxt judgement + (* lists *) + | Prim (loc, I_NIL, [ t ], annot), + stack -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true t >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + typed ctxt loc Nil (Item_t (List_t (t, ty_name), stack, annot)) + | Prim (loc, I_CONS, [], annot), + Item_t (tv, Item_t (List_t (t, ty_name), rest, _), _) -> + check_item_ty ctxt tv t loc I_CONS 1 2 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Cons_list (Item_t (List_t (t, ty_name), rest, annot)) + | Prim (loc, I_IF_CONS, [ bt ; bf ], annot), + (Item_t (List_t (t, ty_name), rest, list_annot) as bef) -> + check_kind [ Seq_kind ] bt >>=? fun () -> + check_kind [ Seq_kind ] bf >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let hd_annot = gen_access_annot list_annot default_hd_annot in + let tl_annot = gen_access_annot list_annot default_tl_annot in + parse_instr ?type_logger tc_context ctxt bt + (Item_t (t, Item_t (List_t (t, ty_name), rest, tl_annot), hd_annot)) + >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf + rest >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + return ctxt judgement + | Prim (loc, I_SIZE, [], annot), + Item_t (List_t _, rest, _) -> + parse_var_type_annot loc annot >>=? fun (annot, tname) -> + typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_MAP, [ body ], annot), + (Item_t (List_t (elt, _), starting_rest, list_annot)) -> + check_kind [ Seq_kind ] body >>=? fun () -> + parse_var_type_annot loc annot + >>=? fun (ret_annot, list_ty_name) -> + let elt_annot = gen_access_annot list_annot default_elt_annot in + parse_instr ?type_logger tc_context ctxt + body (Item_t (elt, starting_rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> + match judgement with + | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> + Invalid_map_body (loc, aft) in + trace_eval invalid_map_body + (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> + typed ctxt loc (List_map ibody) + (Item_t (List_t (ret, list_ty_name), rest, ret_annot))) + | Typed { aft ; _ } -> + serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> + fail (Invalid_map_body (loc, aft)) + | Failed _ -> fail (Invalid_map_block_fail loc) + end + | Prim (loc, I_ITER, [ body ], annot), + Item_t (List_t (elt, _), rest, list_annot) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let elt_annot = gen_access_annot list_annot default_elt_annot in + parse_instr ?type_logger tc_context ctxt + body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> + match judgement with + | Typed ({ aft ; _ } as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> + Invalid_iter_body (loc, rest, aft) in + trace_eval invalid_iter_body + (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + typed ctxt loc (List_iter ibody) rest) + | Failed { descr } -> + typed ctxt loc (List_iter (descr rest)) rest + end + (* sets *) + | Prim (loc, I_EMPTY_SET, [ t ], annot), + rest -> + Lwt.return @@ parse_comparable_ty ctxt t >>=? fun (Ex_comparable_ty t, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, tname) -> + typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot)) + | Prim (loc, I_ITER, [ body ], annot), + Item_t (Set_t (comp_elt, _), rest, set_annot) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let elt_annot = gen_access_annot set_annot default_elt_annot in + let elt = ty_of_comparable_ty comp_elt in + parse_instr ?type_logger tc_context ctxt + body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> + match judgement with + | Typed ({ aft ; _ } as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> + Invalid_iter_body (loc, rest, aft) in + trace_eval invalid_iter_body + (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + typed ctxt loc (Set_iter ibody) rest) + | Failed { descr } -> + typed ctxt loc (Set_iter (descr rest)) rest + end + | Prim (loc, I_MEM, [], annot), + Item_t (v, Item_t (Set_t (elt, _), rest, _), _) -> + let elt = ty_of_comparable_ty elt in + parse_var_type_annot loc annot >>=? fun (annot, tname) -> + check_item_ty ctxt elt v loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot)) + | Prim (loc, I_UPDATE, [], annot), + Item_t (v, Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _), _) -> + let ty = ty_of_comparable_ty elt in + parse_var_annot loc annot ~default:set_annot >>=? fun annot -> + check_item_ty ctxt ty v loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> + typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) + | Prim (loc, I_SIZE, [], annot), + Item_t (Set_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot)) + (* maps *) + | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], annot), + stack -> + Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tv >>=? fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name), stack, annot)) + | Prim (loc, I_MAP, [ body ], annot), + Item_t (Map_t (ck, elt, _), starting_rest, _map_annot) -> + let k = ty_of_comparable_ty ck in + check_kind [ Seq_kind ] body >>=? fun () -> + parse_var_type_annot loc annot >>=? fun (ret_annot, ty_name) -> + let k_name = field_to_var_annot default_key_annot in + let e_name = field_to_var_annot default_elt_annot in + parse_instr ?type_logger tc_context ctxt + body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None), + starting_rest, None)) >>=? begin fun (judgement, ctxt) -> + match judgement with + | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> + Invalid_map_body (loc, aft) in + trace_eval invalid_map_body + (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> + typed ctxt loc (Map_map ibody) + (Item_t (Map_t (ck, ret, ty_name), rest, ret_annot))) + | Typed { aft ; _ } -> + serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> + fail (Invalid_map_body (loc, aft)) + | Failed _ -> fail (Invalid_map_block_fail loc) + end + | Prim (loc, I_ITER, [ body ], annot), + Item_t (Map_t (comp_elt, element_ty, _), rest, _map_annot) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let k_name = field_to_var_annot default_key_annot in + let e_name = field_to_var_annot default_elt_annot in + let key = ty_of_comparable_ty comp_elt in + parse_instr ?type_logger tc_context ctxt body + (Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None), + rest, None)) + >>=? begin fun (judgement, ctxt) -> match judgement with + | Typed ({ aft ; _ } as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> + Invalid_iter_body (loc, rest, aft) in + trace_eval invalid_iter_body + (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + typed ctxt loc (Map_iter ibody) rest) + | Failed { descr } -> + typed ctxt loc (Map_iter (descr rest)) rest + end + | Prim (loc, I_MEM, [], annot), + Item_t (vk, Item_t (Map_t (ck, _, _), rest, _), _) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_GET, [], annot), + Item_t (vk, Item_t (Map_t (ck, elt, _), rest, _), _) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Map_get (Item_t (Option_t ((elt, None), None, None), rest, annot)) + | Prim (loc, I_UPDATE, [], annot), + Item_t (vk, Item_t (Option_t ((vv, _), _, _), + Item_t (Map_t (ck, v, map_name), rest, map_annot), _), _) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vv v loc I_UPDATE 2 3 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot ~default:map_annot >>=? fun annot -> + typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name), rest, annot)) + | Prim (loc, I_SIZE, [], annot), + Item_t (Map_t (_, _, _), rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot)) + (* big_map *) + | Prim (loc, I_MEM, [], annot), + Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) -> + let k = ty_of_comparable_ty map_key in + check_item_ty ctxt set_key k loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_GET, [], annot), + Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Big_map_get (Item_t (Option_t ((elt, None), None, None), rest, annot)) + | Prim (loc, I_UPDATE, [], annot), + Item_t (set_key, + Item_t (Option_t ((set_value, _), _, _), + Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot), _), _) -> + let k = ty_of_comparable_ty map_key in + check_item_ty ctxt set_key k loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot ~default:map_annot >>=? fun annot -> + typed ctxt loc Big_map_update (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot)) + (* control *) + | Seq (loc, []), + stack -> + typed ctxt loc Nop stack + | Seq (loc, [ single ]), + stack -> + parse_instr ?type_logger tc_context ctxt single + stack >>=? begin fun (judgement, ctxt) -> + match judgement with + | Typed ({ aft ; _ } as instr) -> + let nop = { bef = aft ; loc = loc ; aft ; instr = Nop } in + typed ctxt loc (Seq (instr, nop)) aft + | Failed { descr ; _ } -> + let descr aft = + let nop = { bef = aft ; loc = loc ; aft ; instr = Nop } in + let descr = descr aft in + { descr with instr = Seq (descr, nop) } in + return ctxt (Failed { descr }) + end + | Seq (loc, hd :: tl), + stack -> + parse_instr ?type_logger tc_context ctxt hd + stack >>=? begin fun (judgement, ctxt) -> + match judgement with + | Failed _ -> + fail (Fail_not_in_tail_position (Micheline.location hd)) + | Typed ({ aft = middle ; _ } as ihd) -> + parse_instr ?type_logger tc_context ctxt (Seq (-1, tl)) + middle >>=? fun (judgement, ctxt) -> + match judgement with + | Failed { descr } -> + let descr ret = + { loc ; instr = Seq (ihd, descr ret) ; + bef = stack ; aft = ret } in + return ctxt (Failed { descr }) + | Typed itl -> + typed ctxt loc (Seq (ihd, itl)) itl.aft + end + | Prim (loc, I_IF, [ bt ; bf ], annot), + (Item_t (Bool_t _, rest, _) as bef) -> + check_kind [ Seq_kind ] bt >>=? fun () -> + check_kind [ Seq_kind ] bf >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + return ctxt judgement + | Prim (loc, I_LOOP, [ body ], annot), + (Item_t (Bool_t _, rest, _stack_annot) as stack) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + parse_instr ?type_logger tc_context ctxt body + rest >>=? begin fun (judgement, ctxt) -> + match judgement with + | Typed ibody -> + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> + Unmatched_branches (loc, aft, stack) in + trace_eval unmatched_branches + (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> + typed ctxt loc (Loop ibody) rest) + | Failed { descr } -> + let ibody = descr stack in + typed ctxt loc (Loop ibody) rest + end + | Prim (loc, I_LOOP_LEFT, [ body ], annot), + (Item_t (Union_t ((tl, l_field), (tr, _), _), rest, union_annot) as stack) -> + check_kind [ Seq_kind ] body >>=? fun () -> + parse_var_annot loc annot >>=? fun annot -> + let l_annot = gen_access_annot union_annot l_field ~default:default_left_annot in + parse_instr ?type_logger tc_context ctxt body + (Item_t (tl, rest, l_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with + | Typed ibody -> + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> + Unmatched_branches (loc, aft, stack) in + trace_eval unmatched_branches + (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot))) + | Failed { descr } -> + let ibody = descr stack in + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) + end + | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], annot), + stack -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true arg + >>=? fun (Ex_ty arg, ctxt) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true ret + >>=? fun (Ex_ty ret, ctxt) -> + check_kind [ Seq_kind ] code >>=? fun () -> + parse_var_annot loc annot >>=? fun annot -> + parse_returning Lambda ?type_logger ctxt + (arg, default_arg_annot) ret code >>=? fun (lambda, ctxt) -> + typed ctxt loc (Lambda lambda) (Item_t (Lambda_t (arg, ret, None), stack, annot)) + | Prim (loc, I_EXEC, [], annot), + Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) -> + check_item_ty ctxt arg param loc I_EXEC 1 2 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Exec (Item_t (ret, rest, annot)) + | Prim (loc, I_DIP, [ code ], annot), + Item_t (v, rest, stack_annot) -> + fail_unexpected_annot loc annot >>=? fun () -> + check_kind [ Seq_kind ] code >>=? fun () -> + parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt code + rest >>=? begin fun (judgement, ctxt) -> match judgement with + | Typed descr -> + typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) + | Failed _ -> + fail (Fail_not_in_tail_position loc) + end + | Prim (loc, I_FAILWITH, [], annot), + Item_t (v, _rest, _) -> + fail_unexpected_annot loc annot >>=? fun () -> + let descr aft = { loc ; instr = Failwith v ; bef = stack_ty ; aft } in + log_stack ctxt loc stack_ty Empty_t >>=? fun () -> + return ctxt (Failed { descr }) + (* timestamp operations *) + | Prim (loc, I_ADD, [], annot), + Item_t (Timestamp_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Add_timestamp_to_seconds + (Item_t (Timestamp_t tname, rest, annot)) + | Prim (loc, I_ADD, [], annot), + Item_t (Int_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Add_seconds_to_timestamp + (Item_t (Timestamp_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Timestamp_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Sub_timestamp_seconds + (Item_t (Timestamp_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Diff_timestamps + (Item_t (Int_t tname, rest, annot)) + (* string operations *) + | Prim (loc, I_CONCAT, [], annot), + Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Concat_string_pair + (Item_t (String_t tname, rest, annot)) + | Prim (loc, I_CONCAT, [], annot), + Item_t (List_t (String_t tname, _), rest, list_annot) -> + parse_var_annot ~default:list_annot loc annot >>=? fun annot -> + typed ctxt loc Concat_string + (Item_t (String_t tname, rest, annot)) + | Prim (loc, I_SLICE, [], annot), + Item_t (Nat_t _, Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _), _) -> + parse_var_annot + ~default:(gen_access_annot string_annot default_slice_annot) + loc annot >>=? fun annot -> + typed ctxt loc Slice_string + (Item_t (Option_t ((String_t tname, None), None, None), rest, annot)) + | Prim (loc, I_SIZE, [], annot), + Item_t (String_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc String_size (Item_t (Nat_t None, rest, annot)) + (* bytes operations *) + | Prim (loc, I_CONCAT, [], annot), + Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Concat_bytes_pair + (Item_t (Bytes_t tname, rest, annot)) + | Prim (loc, I_CONCAT, [], annot), + Item_t (List_t (Bytes_t tname, _), rest, list_annot) -> + parse_var_annot ~default:list_annot loc annot >>=? fun annot -> + typed ctxt loc Concat_bytes + (Item_t (Bytes_t tname, rest, annot)) + | Prim (loc, I_SLICE, [], annot), + Item_t (Nat_t _, Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _), _) -> + parse_var_annot + ~default:(gen_access_annot bytes_annot default_slice_annot) + loc annot >>=? fun annot -> + typed ctxt loc Slice_bytes + (Item_t (Option_t ((Bytes_t tname, None), None, None), rest, annot)) + | Prim (loc, I_SIZE, [], annot), + Item_t (Bytes_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot)) + (* currency operations *) + | Prim (loc, I_ADD, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Add_tez + (Item_t (Mutez_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Sub_tez + (Item_t (Mutez_t tname, rest, annot)) + | Prim (loc, I_MUL, [], annot), + Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) -> (* no type name check *) + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Mul_teznat + (Item_t (Mutez_t tname, rest, annot)) + | Prim (loc, I_MUL, [], annot), + Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) -> (* no type name check *) + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Mul_nattez + (Item_t (Mutez_t tname, rest, annot)) + (* boolean operations *) + | Prim (loc, I_OR, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Or + (Item_t (Bool_t tname, rest, annot)) + | Prim (loc, I_AND, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc And + (Item_t (Bool_t tname, rest, annot)) + | Prim (loc, I_XOR, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Xor + (Item_t (Bool_t tname, rest, annot)) + | Prim (loc, I_NOT, [], annot), + Item_t (Bool_t tname, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Not + (Item_t (Bool_t tname, rest, annot)) + (* integer operations *) + | Prim (loc, I_ABS, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Abs_int + (Item_t (Nat_t None, rest, annot)) + | Prim (loc, I_ISNAT, [], annot), + Item_t (Int_t _, rest, int_annot) -> + parse_var_annot loc annot ~default:int_annot >>=? fun annot -> + typed ctxt loc Is_nat + (Item_t (Option_t ((Nat_t None, None), None, None), rest, annot)) + | Prim (loc, I_INT, [], annot), + Item_t (Nat_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Int_nat + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_NEG, [], annot), + Item_t (Int_t tname, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Neg_int + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_NEG, [], annot), + Item_t (Nat_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Neg_nat + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_ADD, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Add_intint + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_ADD, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Add_intnat + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_ADD, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Add_natint + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_ADD, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Add_natnat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Sub_int + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Sub_int + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Sub_int + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_SUB, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun _tname -> + typed ctxt loc Sub_int + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_MUL, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Mul_intint + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_MUL, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Mul_intnat + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_MUL, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Mul_natint + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_MUL, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Mul_natnat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_EDIV, [], annot), + Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Ediv_teznat + (Item_t (Option_t + ((Pair_t ((Mutez_t tname, None, None), + (Mutez_t tname, None, None), None), None), + None, None), rest, annot)) + | Prim (loc, I_EDIV, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Ediv_tez + (Item_t (Option_t ((Pair_t ((Nat_t None, None, None), + (Mutez_t tname, None, None), None), None), + None, None), rest, annot)) + | Prim (loc, I_EDIV, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Ediv_intint + (Item_t (Option_t + ((Pair_t ((Int_t tname, None, None), + (Nat_t None, None, None), None), None), + None, None), rest, annot)) + | Prim (loc, I_EDIV, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Ediv_intnat + (Item_t (Option_t + ((Pair_t ((Int_t tname, None, None), + (Nat_t None, None, None), None), None), + None, None), rest, annot)) + | Prim (loc, I_EDIV, [], annot), + Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Ediv_natint + (Item_t (Option_t ((Pair_t ((Int_t None, None, None), + (Nat_t tname, None, None), None), None), + None, None), rest, annot)) + | Prim (loc, I_EDIV, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Ediv_natnat + (Item_t (Option_t ((Pair_t ((Nat_t tname, None, None), + (Nat_t tname, None, None), None), None), + None, None), rest, annot)) + | Prim (loc, I_LSL, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Lsl_nat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_LSR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Lsr_nat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_OR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Or_nat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_AND, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc And_nat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_AND, [], annot), + Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc And_int_nat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_XOR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc Xor_nat + (Item_t (Nat_t tname, rest, annot)) + | Prim (loc, I_NOT, [], annot), + Item_t (Int_t tname, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Not_int + (Item_t (Int_t tname, rest, annot)) + | Prim (loc, I_NOT, [], annot), + Item_t (Nat_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Not_nat + (Item_t (Int_t None, rest, annot)) + (* comparison *) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Int_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Nat_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Bool_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (String_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Mutez_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Key_hash_t tn1, Item_t (Key_hash_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Key_hash_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Timestamp_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Address_t tn1, Item_t (Address_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Address_key tname)) + (Item_t (Int_t None, rest, annot)) + | Prim (loc, I_COMPARE, [], annot), + Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + typed ctxt loc (Compare (Bytes_key tname)) + (Item_t (Int_t None, rest, annot)) + (* comparators *) + | Prim (loc, I_EQ, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Eq + (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_NEQ, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Neq + (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_LT, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Lt + (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_GT, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Gt + (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_LE, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Le + (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_GE, [], annot), + Item_t (Int_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Ge + (Item_t (Bool_t None, rest, annot)) + (* annotations *) + | Prim (loc, I_CAST, [ cast_t ], annot), + Item_t (t, stack, item_annot) -> + parse_var_annot loc annot ~default:item_annot >>=? fun annot -> + (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true cast_t) + >>=? fun (Ex_ty cast_t, ctxt) -> + Lwt.return @@ ty_eq ctxt cast_t t >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ctxt loc cast_t t >>=? fun (_, ctxt) -> + typed ctxt loc Nop (Item_t (cast_t, stack, annot)) + | Prim (loc, I_RENAME, [], annot), + Item_t (t, stack, _) -> + parse_var_annot loc annot >>=? fun annot -> (* can erase annot *) + typed ctxt loc Nop (Item_t (t, stack, annot)) + (* packing *) + | Prim (loc, I_PACK, [], annot), + Item_t (t, rest, unpacked_annot) -> + Lwt.return (check_no_big_map_or_operation loc t) >>=? fun () -> + parse_var_annot loc annot ~default:(gen_access_annot unpacked_annot default_pack_annot) + >>=? fun annot -> + typed ctxt loc (Pack t) + (Item_t (Bytes_t None, rest, annot)) + | Prim (loc, I_UNPACK, [ ty ], annot), + Item_t (Bytes_t _, rest, packed_annot) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t, ctxt) -> + let stack_annot = gen_access_annot packed_annot default_unpack_annot in + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, ty_name, some_field, none_field) -> + typed ctxt loc (Unpack t) + (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) + (* protocol *) + | Prim (loc, I_ADDRESS, [], annot), + Item_t (Contract_t _, rest, contract_annot) -> + parse_var_annot loc annot ~default:(gen_access_annot contract_annot default_addr_annot) + >>=? fun annot -> + typed ctxt loc Address + (Item_t (Address_t None, rest, annot)) + | Prim (loc, I_CONTRACT, [ ty ], annot), + Item_t (Address_t _, rest, addr_annot) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t, ctxt) -> + parse_var_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) + >>=? fun annot -> + typed ctxt loc (Contract t) + (Item_t (Option_t ((Contract_t (t, None), None), None, None), rest, annot)) + | Prim (loc, I_TRANSFER_TOKENS, [], annot), + Item_t (p, Item_t + (Mutez_t _, Item_t + (Contract_t (cp, _), rest, _), _), _) -> + check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot)) + | Prim (loc, I_SET_DELEGATE, [], annot), + Item_t (Option_t ((Key_hash_t _, _), _, _), rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) + | Prim (loc, I_CREATE_ACCOUNT, [], annot), + Item_t + (Key_hash_t _, Item_t + (Option_t ((Key_hash_t _, _), _, _), Item_t + (Bool_t _, Item_t + (Mutez_t _, rest, _), _), _), _) -> + parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + typed ctxt loc Create_account + (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), + Item_t (Key_hash_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Implicit_account + (Item_t (Contract_t (Unit_t None, None), rest, annot)) + | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), + Item_t + (Key_hash_t _, Item_t + (Option_t ((Key_hash_t _, _), _, _), Item_t + (Bool_t _, Item_t + (Bool_t _, Item_t + (Mutez_t _, Item_t + (ginit, rest, _), _), _), _), _), _) -> + parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + let cannonical_code = fst @@ Micheline.extract_locations code in + Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) -> + trace + (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) + (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type) + >>=? fun (Ex_ty arg_type, ctxt) -> + trace + (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) + (Lwt.return @@ parse_storage_ty ctxt storage_type) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot in + let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot in + let arg_type_full = Pair_t ((arg_type, None, arg_annot), + (storage_type, None, storage_annot), None) in + let ret_type_full = + Pair_t ((List_t (Operation_t None, None), None, None), + (storage_type, None, None), None) in + trace + (Ill_typed_contract (cannonical_code, [])) + (parse_returning (Toplevel { storage_type ; param_type = arg_type }) + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; + aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> + Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ctxt loc storage_type ginit >>=? fun (_, ctxt) -> + typed ctxt loc (Create_contract (storage_type, arg_type, lambda)) + (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + | Prim (loc, I_NOW, [], annot), + stack -> + parse_var_annot loc annot ~default:default_now_annot >>=? fun annot -> + typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot)) + | Prim (loc, I_AMOUNT, [], annot), + stack -> + parse_var_annot loc annot ~default:default_amount_annot >>=? fun annot -> + typed ctxt loc Amount + (Item_t (Mutez_t None, stack, annot)) + | Prim (loc, I_BALANCE, [], annot), + stack -> + parse_var_annot loc annot ~default:default_balance_annot >>=? fun annot -> + typed ctxt loc Balance + (Item_t (Mutez_t None, stack, annot)) + | Prim (loc, I_HASH_KEY, [], annot), + Item_t (Key_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Hash_key + (Item_t (Key_hash_t None, rest, annot)) + | Prim (loc, I_CHECK_SIGNATURE, [], annot), + Item_t (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Check_signature + (Item_t (Bool_t None, rest, annot)) + | Prim (loc, I_BLAKE2B, [], annot), + Item_t (Bytes_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Blake2b + (Item_t (Bytes_t None, rest, annot)) + | Prim (loc, I_SHA256, [], annot), + Item_t (Bytes_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Sha256 + (Item_t (Bytes_t None, rest, annot)) + | Prim (loc, I_SHA512, [], annot), + Item_t (Bytes_t _, rest, _) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc Sha512 + (Item_t (Bytes_t None, rest, annot)) + | Prim (loc, I_STEPS_TO_QUOTA, [], annot), + stack -> + parse_var_annot loc annot ~default:default_steps_annot >>=? fun annot -> + typed ctxt loc Steps_to_quota + (Item_t (Nat_t None, stack, annot)) + | Prim (loc, I_SOURCE, [], annot), + stack -> + parse_var_annot loc annot ~default:default_source_annot >>=? fun annot -> + typed ctxt loc Source + (Item_t (Address_t None, stack, annot)) + | Prim (loc, I_SENDER, [], annot), + stack -> + parse_var_annot loc annot ~default:default_sender_annot >>=? fun annot -> + typed ctxt loc Sender + (Item_t (Address_t None, stack, annot)) + | Prim (loc, I_SELF, [], annot), + stack -> + parse_var_annot loc annot ~default:default_self_annot >>=? fun annot -> + let rec get_toplevel_type : tc_context -> (bef judgement * context) tzresult Lwt.t = function + | Lambda -> fail (Self_in_lambda loc) + | Dip (_, prev) -> get_toplevel_type prev + | Toplevel { param_type ; _ } -> + typed ctxt loc (Self param_type) + (Item_t (Contract_t (param_type, None), stack, annot)) in + get_toplevel_type tc_context + (* Primitive parsing errors *) + | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT + | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT | I_SLICE + | I_MEM | I_UPDATE | I_MAP + | I_GET | I_EXEC | I_FAILWITH | I_SIZE + | I_ADD | I_SUB + | I_MUL | I_EDIV | I_OR | I_AND | I_XOR + | I_NOT + | I_ABS | I_NEG | I_LSL | I_LSR + | I_COMPARE | I_EQ | I_NEQ + | I_LT | I_GT | I_LE | I_GE + | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT | I_SET_DELEGATE | I_NOW + | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE + | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE | I_SENDER + | I_BLAKE2B | I_SHA256 | I_SHA512 | I_STEPS_TO_QUOTA | I_ADDRESS + as name), (_ :: _ as l), _), _ -> + fail (Invalid_arity (loc, name, 0, List.length l)) + | Prim (loc, (I_NONE | I_LEFT | I_RIGHT | I_NIL | I_MAP | I_ITER + | I_EMPTY_SET | I_DIP | I_LOOP | I_LOOP_LEFT | I_CONTRACT + as name), ([] + | _ :: _ :: _ as l), _), _ -> + fail (Invalid_arity (loc, name, 1, List.length l)) + | Prim (loc, (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS + | I_EMPTY_MAP | I_IF + as name), ([] | [ _ ] + | _ :: _ :: _ :: _ as l), _), _ -> + fail (Invalid_arity (loc, name, 2, List.length l)) + | Prim (loc, I_LAMBDA, ([] | [ _ ] + | _ :: _ :: _ :: _ :: _ as l), _), _ -> + fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) + (* Stack errors *) + | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV + | I_AND | I_OR | I_XOR | I_LSL | I_LSR + | I_COMPARE as name), [], _), + Item_t (ta, Item_t (tb, _, _), _) -> + Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) -> + Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) -> + fail (Undefined_binop (loc, name, ta, tb)) + | Prim (loc, (I_NEG | I_ABS | I_NOT | I_CONCAT | I_SIZE + | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), + [], _), + Item_t (t, _, _) -> + Lwt.return @@ serialize_ty_for_error ctxt t >>=? fun (t, _ctxt) -> + fail (Undefined_unop (loc, name, t)) + | Prim (loc, (I_UPDATE | I_SLICE as name), [], _), + stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, name, 3, stack)) + | Prim (loc, I_CREATE_CONTRACT, [], _), + stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) + | Prim (loc, I_CREATE_ACCOUNT, [], _), + stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack)) + | Prim (loc, I_TRANSFER_TOKENS, [], _), + stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) + | Prim (loc, (I_DROP | I_DUP | I_CAR | I_CDR | I_SOME + | I_BLAKE2B | I_SHA256 | I_SHA512 | I_DIP + | I_IF_NONE | I_LEFT | I_RIGHT | I_IF_LEFT | I_IF + | I_LOOP | I_IF_CONS | I_IMPLICIT_ACCOUNT + | I_NEG | I_ABS | I_INT | I_NOT | I_HASH_KEY + | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), _, _), + stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, name, 1, stack)) + | Prim (loc, (I_SWAP | I_PAIR | I_CONS + | I_GET | I_MEM | I_EXEC + | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL + | I_EDIV | I_AND | I_OR | I_XOR + | I_LSL | I_LSR as name), _, _), + stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, name, 2, stack)) + (* Generic parsing errors *) + | expr, _ -> + fail @@ unexpected expr [ Seq_kind ] Instr_namespace + [ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ; + I_PAIR ; I_CAR ; I_CDR ; I_CONS ; + I_MEM ; I_UPDATE ; I_MAP ; I_ITER ; + I_GET ; I_EXEC ; I_FAILWITH ; I_SIZE ; + I_CONCAT ; I_ADD ; I_SUB ; + I_MUL ; I_EDIV ; I_OR ; I_AND ; I_XOR ; + I_NOT ; + I_ABS ; I_INT; I_NEG ; I_LSL ; I_LSR ; + I_COMPARE ; I_EQ ; I_NEQ ; + I_LT ; I_GT ; I_LE ; I_GE ; + I_TRANSFER_TOKENS ; I_CREATE_ACCOUNT ; + I_CREATE_CONTRACT ; I_NOW ; I_AMOUNT ; I_BALANCE ; + I_IMPLICIT_ACCOUNT ; I_CHECK_SIGNATURE ; + I_BLAKE2B ; I_SHA256 ; I_SHA512 ; I_HASH_KEY ; + I_STEPS_TO_QUOTA ; + I_PUSH ; I_NONE ; I_LEFT ; I_RIGHT ; I_NIL ; + I_EMPTY_SET ; I_DIP ; I_LOOP ; + I_IF_NONE ; I_IF_LEFT ; I_IF_CONS ; + I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SENDER ; I_SELF ; I_LAMBDA ] + +and parse_contract + : type arg. context -> Script.location -> arg ty -> Contract.t -> + (context * arg typed_contract) tzresult Lwt.t + = fun ctxt loc arg contract -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> + Contract.exists ctxt contract >>=? function + | false -> fail (Invalid_contract (loc, contract)) + | true -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> + trace + (Invalid_contract (loc, contract)) @@ + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with + | None -> + Lwt.return + (ty_eq ctxt arg (Unit_t None) >>? fun (Eq, ctxt) -> + let contract : arg typed_contract = (arg, contract) in + ok (ctxt, contract)) + | Some { code ; _ } -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> + Lwt.return + (parse_toplevel code >>? fun (arg_type, _, _) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, ctxt) -> + ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> + merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, contract) in + ok (ctxt, contract)) + +(* Same as the one above, but does not fail when the contact is missing or + if the expected type doesn't match the actual one. In that case None is + returned and some overapproximation of the typechecking gas is consumed. + This can still fail on gas exhaustion. *) +and parse_contract_for_script + : type arg. context -> Script.location -> arg ty -> Contract.t -> + (context * arg typed_contract option) tzresult Lwt.t + = fun ctxt loc arg contract -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> + Contract.exists ctxt contract >>=? function + | false -> return (ctxt, None) + | true -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> + trace + (Invalid_contract (loc, contract)) @@ + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with (* can only fail because of gas *) + | None -> + Lwt.return + (match ty_eq ctxt arg (Unit_t None) with + | Ok (Eq, ctxt) -> + let contract : arg typed_contract = (arg, contract) in + ok (ctxt, Some contract) + | Error _ -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + ok (ctxt, None)) + | Some { code ; _ } -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> (* can only fail because of gas *) + Lwt.return + (match parse_toplevel code with + | Error _ -> error (Invalid_contract (loc, contract)) + | Ok (arg_type, _, _) -> + match parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type with + | Error _ -> + error (Invalid_contract (loc, contract)) + | Ok (Ex_ty targ, ctxt) -> + match + (ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> + merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, contract) in + ok (ctxt, Some contract)) + with + | Ok res -> ok res + | Error _ -> + (* overapproximation by checking if targ = targ, + can only fail because of gas *) + ty_eq ctxt targ targ >>? fun (Eq, ctxt) -> + merge_types ctxt loc targ targ >>? fun (_, ctxt) -> + ok (ctxt, None)) + +and parse_toplevel + : Script.expr -> (Script.node * Script.node * Script.node) tzresult + = fun toplevel -> + record_trace (Ill_typed_contract (toplevel, [])) @@ + match root toplevel with + | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) + | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) + | Bytes (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Bytes_kind)) + | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) + | Seq (_, fields) -> + let rec find_fields p s c fields = + match fields with + | [] -> ok (p, s, c) + | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) + | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) + | Bytes (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Bytes_kind)) + | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) + | Prim (loc, K_parameter, [ arg ], _) :: rest -> + begin match p with + | None -> find_fields (Some arg) s c rest + | Some _ -> error (Duplicate_field (loc, K_parameter)) + end + | Prim (loc, K_storage, [ arg ], _) :: rest -> + begin match s with + | None -> find_fields p (Some arg) c rest + | Some _ -> error (Duplicate_field (loc, K_storage)) + end + | Prim (loc, K_code, [ arg ], _) :: rest -> + begin match c with + | None -> find_fields p s (Some arg) rest + | Some _ -> error (Duplicate_field (loc, K_code)) + end + | Prim (loc, (K_parameter | K_storage | K_code as name), args, _) :: _ -> + error (Invalid_arity (loc, name, 1, List.length args)) + | Prim (loc, name, _, _) :: _ -> + let allowed = [ K_parameter ; K_storage ; K_code ] in + error (Invalid_primitive (loc, allowed, name)) + in + find_fields None None None fields >>? function + | (None, _, _) -> error (Missing_field K_parameter) + | (Some _, None, _) -> error (Missing_field K_storage) + | (Some _, Some _, None) -> error (Missing_field K_code) + | (Some p, Some s, Some c) -> ok (p, s, c) + +let parse_script + : ?type_logger: type_logger -> + context -> Script.t -> (ex_script * context) tzresult Lwt.t + = fun ?type_logger ctxt { code ; storage } -> + Script.force_decode ctxt code >>=? fun (code, ctxt) -> + Script.force_decode ctxt storage >>=? fun (storage, ctxt) -> + Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> + trace + (Ill_formed_type (Some "parameter", code, location arg_type)) + (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) + >>=? fun (Ex_ty arg_type, ctxt) -> + trace + (Ill_formed_type (Some "storage", code, location storage_type)) + (Lwt.return (parse_storage_ty ctxt storage_type)) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot in + let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot in + let arg_type_full = Pair_t ((arg_type, None, arg_annot), + (storage_type, None, storage_annot), None) in + let ret_type_full = + Pair_t ((List_t (Operation_t None, None), None, None), + (storage_type, None, None), None) in + trace_eval + (fun () -> + Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) -> + Ill_typed_data (None, storage, storage_type)) + (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> + trace + (Ill_typed_contract (code, [])) + (parse_returning (Toplevel { storage_type ; param_type = arg_type }) + ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> + return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) + +let typecheck_code + : context -> Script.expr -> (type_map * context) tzresult Lwt.t + = fun ctxt code -> + Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> + let type_map = ref [] in + (* TODO: annotation checking *) + trace + (Ill_formed_type (Some "parameter", code, location arg_type)) + (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) + >>=? fun (Ex_ty arg_type, ctxt) -> + trace + (Ill_formed_type (Some "storage", code, location storage_type)) + (Lwt.return (parse_storage_ty ctxt storage_type)) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot in + let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot in + let arg_type_full = Pair_t ((arg_type, None, arg_annot), + (storage_type, None, storage_annot), None) in + let ret_type_full = + Pair_t ((List_t (Operation_t None, None), None, None), + (storage_type, None, None), None) in + let result = + parse_returning + (Toplevel { storage_type ; param_type = arg_type }) + ctxt + ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) + (arg_type_full, None) ret_type_full code_field in + trace + (Ill_typed_contract (code, !type_map)) + result >>=? fun (Lam _, ctxt) -> + return (!type_map, ctxt) + +let typecheck_data + : ?type_logger: type_logger -> + context -> Script.expr * Script.expr -> context tzresult Lwt.t + = fun ?type_logger ctxt (data, exp_ty) -> + trace + (Ill_formed_type (None, exp_ty, 0)) + (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false (root exp_ty)) + >>=? fun (Ex_ty exp_ty, ctxt) -> + trace_eval + (fun () -> + Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) -> + Ill_typed_data (None, data, exp_ty)) + (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> + return ctxt + +(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) + +let rec unparse_data + : type a. context -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t + = fun ctxt mode ty a -> + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> + match ty, a with + | Unit_t _, () -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> + return (Prim (-1, D_Unit, [], []), ctxt) + | Int_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | Nat_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | String_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> + return (String (-1, s), ctxt) + | Bytes_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> + return (Bytes (-1, s), ctxt) + | Bool_t _, true -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_True, [], []), ctxt) + | Bool_t _, false -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_False, [], []), ctxt) + | Timestamp_t _, t -> + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> + begin + match mode with + | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> + match Script_timestamp.to_notation t with + | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (-1, s), ctxt) + end + | Address_t _, c -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Contract_t _, (_, c) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Signature_t _, s -> + Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) + end + | Mutez_t _, v -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> + return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | Key_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) + end + | Key_hash_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + end + | Operation_t _, op -> + let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> + unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> + unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) + | Union_t ((tl, _), _, _), L l -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> + return (Prim (-1, D_Left, [ l ], []), ctxt) + | Union_t (_, (tr, _), _), R r -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Right, [ r ], []), ctxt) + | Option_t ((t, _), _, _), Some v -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> + unparse_data ctxt mode t v >>=? fun (v, ctxt) -> + return (Prim (-1, D_Some, [ v ], []), ctxt) + | Option_t _, None -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> + return (Prim (-1, D_None, [], []), ctxt) + | List_t (t, _), items -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> + unparse_data ctxt mode t element >>=? fun (unparsed, ctxt) -> + return (unparsed :: l, ctxt)) + ([], ctxt) + items >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | Set_t (t, _), set -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> + unparse_data ctxt mode t item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Map_t (kt, vt, _), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), _map -> + return (Micheline.Seq (-1, []), ctxt) + | Lambda_t _, Lam (_, original_code) -> + unparse_code ctxt mode (root original_code) + +(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) +and unparse_code ctxt mode = function + | Prim (loc, I_PUSH, [ ty ; data ], annot) -> + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt t data >>=? fun (data, ctxt) -> + unparse_data ctxt mode t data >>=? fun (data, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> + return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) + | Seq (loc, items) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code ctxt mode item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> + return (Micheline.Seq (loc, List.rev items), ctxt) + | Prim (loc, prim, items, annot) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code ctxt mode item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> + return (Prim (loc, prim, List.rev items, annot), ctxt) + | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) + +(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) +let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = + let Lam (_, original_code) = code in + unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> + unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> + unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) -> + let open Micheline in + let code = + Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; + Prim (-1, K_storage, [ storage_type ], []) ; + Prim (-1, K_code, [ code ], []) ]) in + Lwt.return + (Gas.consume ctxt (Unparse_costs.seq_cost 3) >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.prim_cost 1 []) >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.prim_cost 1 []) >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.prim_cost 1 [])) >>=? fun ctxt -> + return ({ code = lazy_expr (strip_locations code) ; + storage = lazy_expr (strip_locations storage) }, ctxt) + +let pack_data ctxt typ data = + unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) -> + let unparsed = strip_annotations @@ data in + let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in + Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> + let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in + Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> + return (bytes, ctxt) + +let hash_data ctxt typ data = + pack_data ctxt typ data >>=? fun (bytes, ctxt) -> + Lwt.return @@ Gas.consume ctxt + (Michelson_v1_gas.Cost_of.hash bytes Script_expr_hash.size) >>=? fun ctxt -> + return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) + +(* ---------------- Big map -------------------------------------------------*) + +let big_map_mem ctxt contract key { diff ; key_type ; _ } = + match map_get key diff with + | None -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> + Alpha_context.Contract.Big_map.mem ctxt contract hash >>=? fun (ctxt, res) -> + return (res, ctxt) + | Some None -> return (false, ctxt) + | Some (Some _) -> return (true, ctxt) + +let big_map_get ctxt contract key { diff ; key_type ; value_type } = + match map_get key diff with + | Some x -> return (x, ctxt) + | None -> + hash_data ctxt key_type key >>=? fun (hash, ctxt) -> + Alpha_context.Contract.Big_map.get_opt + ctxt contract hash >>=? begin function + | (ctxt, None) -> return (None, ctxt) + | (ctxt, Some value) -> + parse_data ctxt value_type + (Micheline.root value) >>=? fun (x, ctxt) -> + return (Some x, ctxt) + end + +let big_map_update key value ({ diff ; _ } as map) = + { map with diff = map_set key value diff } + +let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) = + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.map_to_list diff)) >>=? fun ctxt -> + let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in + fold_left_s + (fun (acc, ctxt) (key, value) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + hash_data ctxt key_type key >>=? fun (diff_key_hash, ctxt) -> + unparse_data ctxt mode key_type key >>=? fun (key_node, ctxt) -> + let diff_key = Micheline.strip_locations key_node in + begin + match value with + | None -> return (None, ctxt) + | Some x -> + begin + unparse_data ctxt mode value_type x >>=? fun (node, ctxt) -> + return (Some (Micheline.strip_locations node), ctxt) + end + end >>=? fun (diff_value, ctxt) -> + let diff_item = Contract.{ diff_key ; diff_key_hash ; diff_value } in + return (diff_item :: acc, ctxt)) + ([], ctxt) pairs + +(* Get the big map from a contract's storage if one exists *) +let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> + match (ty, x) with + | Pair_t ((Big_map_t (_, _, _), _, _), _, _), (map, _) -> Some (Ex_bm map) + | _, _ -> None + +let big_map_initialization ctxt mode (Ex_script { storage ; storage_type; _ }) = + match extract_big_map storage_type storage with + | None -> return (None, ctxt) + | Some bm -> + diff_of_big_map ctxt mode bm >>=? fun (bm, ctxt) -> return (Some bm, ctxt) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli new file mode 100644 index 000000000..64eb6f534 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli @@ -0,0 +1,154 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_tc_errors + +type ('ta, 'tb) eq = Eq : ('same, 'same) eq + +type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty +type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty +type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty +type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script + +type tc_context = + | Lambda : tc_context + | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context + | Toplevel : { storage_type : 'sto Script_typed_ir.ty ; param_type : 'param Script_typed_ir.ty } -> tc_context + +type unparsing_mode = Optimized | Readable + +type type_logger = + int -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit + +(* ---- Sets and Maps -------------------------------------------------------*) + +val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set +val set_fold : + ('elt -> 'acc -> 'acc) -> + 'elt Script_typed_ir.set -> 'acc -> 'acc +val set_update : 'a -> bool -> 'a Script_typed_ir.set -> 'a Script_typed_ir.set +val set_mem : 'elt -> 'elt Script_typed_ir.set -> bool +val set_size : 'elt Script_typed_ir.set -> Script_int.n Script_int.num + +val empty_map : 'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map +val map_fold : + ('key -> 'value -> 'acc -> 'acc) -> + ('key, 'value) Script_typed_ir.map -> 'acc -> 'acc +val map_update : + 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> ('a, 'b) Script_typed_ir.map +val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool +val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option +val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty +val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num + +val big_map_mem : + context -> Contract.t -> 'key -> + ('key, 'value) Script_typed_ir.big_map -> + (bool * context) tzresult Lwt.t +val big_map_get : + context -> + Contract.t -> 'key -> + ('key, 'value) Script_typed_ir.big_map -> + ('value option * context) tzresult Lwt.t +val big_map_update : + 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> + ('key, 'value) Script_typed_ir.big_map + +val ty_of_comparable_ty : + 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ty + + +val ty_eq : + context -> + 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> + (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult + +val parse_data : + ?type_logger: type_logger -> + context -> + 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t +val unparse_data : + context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a -> + (Script.node * context) tzresult Lwt.t + +val parse_ty : + context -> + allow_big_map: bool -> + allow_operation: bool -> + Script.node -> (ex_ty * context) tzresult + +val unparse_ty : + context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t + +val parse_toplevel : + Script.expr -> (Script.node * Script.node * Script.node) tzresult + +val typecheck_code : + context -> Script.expr -> (type_map * context) tzresult Lwt.t + +val typecheck_data : + ?type_logger: type_logger -> + context -> Script.expr * Script.expr -> context tzresult Lwt.t + +type 'bef judgement = + | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement + | Failed : { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement + +val parse_instr : + ?type_logger: type_logger -> + tc_context -> context -> + Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t + +val parse_script : + ?type_logger: type_logger -> + context -> Script.t -> (ex_script * context) tzresult Lwt.t + +(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) +val unparse_script : + context -> unparsing_mode -> + ('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t + +val parse_contract : + context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t + +val parse_contract_for_script : + context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t + +val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t +val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t + +val extract_big_map : + 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option + +val diff_of_big_map : + context -> unparsing_mode -> Script_typed_ir.ex_big_map -> + (Contract.big_map_diff * context) tzresult Lwt.t + +val big_map_initialization : + context -> unparsing_mode -> ex_script -> + (Contract.big_map_diff option * context) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml new file mode 100644 index 000000000..c51cfd8f3 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml @@ -0,0 +1,197 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type location = Micheline.canonical_location + +let location_encoding = Micheline.canonical_location_encoding + +type annot = Micheline.annot + +type expr = Michelson_v1_primitives.prim Micheline.canonical + +type lazy_expr = expr Data_encoding.lazy_t + +type node = (location, Michelson_v1_primitives.prim) Micheline.node + + + +let expr_encoding = + Micheline.canonical_encoding_v1 + ~variant:"michelson_v1" + Michelson_v1_primitives.prim_encoding + +type error += Lazy_script_decode (* `Permanent *) + +let () = + register_error_kind `Permanent + ~id:"invalid_binary_format" + ~title:"Invalid binary format" + ~description:"Could not deserialize some piece of data \ + from its binary representation" + Data_encoding.empty + (function Lazy_script_decode -> Some () | _ -> None) + (fun () -> Lazy_script_decode) + +let lazy_expr_encoding = + Data_encoding.lazy_encoding expr_encoding + +let lazy_expr expr = + Data_encoding.make_lazy expr_encoding expr + +type t = { + code : lazy_expr ; + storage : lazy_expr +} + +let encoding = + let open Data_encoding in + def "scripted.contracts" @@ + conv + (fun { code ; storage } -> (code, storage)) + (fun (code, storage) -> { code ; storage }) + (obj2 + (req "code" lazy_expr_encoding) + (req "storage" lazy_expr_encoding)) + +let int_node_size_of_numbits n = + (1, 1 + (n + 63) / 64) +let int_node_size n = + int_node_size_of_numbits (Z.numbits n) +let string_node_size_of_length s = + (1, 1 + (s + 7) / 8) +let string_node_size s = + string_node_size_of_length (String.length s) +let bytes_node_size_of_length s = + (* approx cost of indirection to the C heap *) + (2, 1 + (s + 7) / 8 + 12) +let bytes_node_size s = + bytes_node_size_of_length (MBytes.length s) +let prim_node_size_nonrec_of_lengths n_args annots = + let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in + if Compare.Int.(annots_length = 0) then + (1 + n_args, 2 + 2 * n_args) + else + (2 + n_args, 4 + 2 * n_args + (annots_length + 7) / 8) +let prim_node_size_nonrec args annots = + let n_args = List.length args in + prim_node_size_nonrec_of_lengths n_args annots +let seq_node_size_nonrec_of_length n_args = + (1 + n_args, 2 + 2 * n_args) +let seq_node_size_nonrec args = + let n_args = List.length args in + seq_node_size_nonrec_of_length n_args + +let rec node_size node = + let open Micheline in + match node with + | Int (_, n) -> int_node_size n + | String (_, s) -> string_node_size s + | Bytes (_, s) -> bytes_node_size s + | Prim (_, _, args, annot) -> + List.fold_left + (fun (blocks, words) node -> + let (nblocks, nwords) = node_size node in + (blocks + nblocks, words + nwords)) + (prim_node_size_nonrec args annot) + args + | Seq (_, args) -> + List.fold_left + (fun (blocks, words) node -> + let (nblocks, nwords) = node_size node in + (blocks + nblocks, words + nwords)) + (seq_node_size_nonrec args) + args + +let expr_size expr = + node_size (Micheline.root expr) + +let traversal_cost node = + let blocks, _words = node_size node in + Gas_limit_repr.step_cost blocks + +let cost_of_size (blocks, words) = + let open Gas_limit_repr in + ((Compare.Int.max 0 (blocks - 1)) *@ alloc_cost 0) +@ + alloc_cost words +@ + step_cost blocks + +let node_cost node = + cost_of_size (node_size node) + +let int_node_cost n = cost_of_size (int_node_size n) +let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n) +let string_node_cost s = cost_of_size (string_node_size s) +let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s) +let bytes_node_cost s = cost_of_size (bytes_node_size s) +let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s) +let prim_node_cost_nonrec args annot = cost_of_size (prim_node_size_nonrec args annot) +let prim_node_cost_nonrec_of_length n_args annot = cost_of_size (prim_node_size_nonrec_of_lengths n_args annot) +let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args) +let seq_node_cost_nonrec_of_length n_args = cost_of_size (seq_node_size_nonrec_of_length n_args) + +let deserialized_cost expr = + cost_of_size (expr_size expr) + +let serialized_cost bytes = + let open Gas_limit_repr in + alloc_mbytes_cost (MBytes.length bytes) + +let force_decode lexpr = + let account_deserialization_cost = + Data_encoding.apply_lazy + ~fun_value:(fun _ -> false) + ~fun_bytes:(fun _ -> true) + ~fun_combine:(fun _ _ -> false) + lexpr in + match Data_encoding.force_decode lexpr with + | Some v -> + if account_deserialization_cost then + ok (v, deserialized_cost v) + else + ok (v, Gas_limit_repr.free) + | None -> error Lazy_script_decode + +let force_bytes expr = + let open Gas_limit_repr in + let account_serialization_cost = + Data_encoding.apply_lazy + ~fun_value:(fun v -> Some v) + ~fun_bytes:(fun _ -> None) + ~fun_combine:(fun _ _ -> None) + expr in + match Data_encoding.force_bytes expr with + | bytes -> + begin match account_serialization_cost with + | Some v -> ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes) + | None -> ok (bytes, Gas_limit_repr.free) + end + | exception _ -> error Lazy_script_decode + +let minimal_deserialize_cost lexpr = + Data_encoding.apply_lazy + ~fun_value:(fun _ -> Gas_limit_repr.free) + ~fun_bytes:(fun b -> serialized_cost b) + ~fun_combine:(fun c_free _ -> c_free) + lexpr diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli new file mode 100644 index 000000000..34dc0d90a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli @@ -0,0 +1,71 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type location = Micheline.canonical_location + +type annot = Micheline.annot + +type expr = Michelson_v1_primitives.prim Micheline.canonical + +type error += Lazy_script_decode (* `Permanent *) + +type lazy_expr = expr Data_encoding.lazy_t + +type node = (location, Michelson_v1_primitives.prim) Micheline.node + +val location_encoding : location Data_encoding.t + +val expr_encoding : expr Data_encoding.t + +val lazy_expr_encoding : lazy_expr Data_encoding.t + +val lazy_expr : expr -> lazy_expr + +type t = { code : lazy_expr ; storage : lazy_expr } + +val encoding : t Data_encoding.encoding + +val deserialized_cost : expr -> Gas_limit_repr.cost + +val serialized_cost : MBytes.t -> Gas_limit_repr.cost +val traversal_cost : node -> Gas_limit_repr.cost +val node_cost : node -> Gas_limit_repr.cost + +val int_node_cost : Z.t -> Gas_limit_repr.cost +val int_node_cost_of_numbits : int -> Gas_limit_repr.cost +val string_node_cost : string -> Gas_limit_repr.cost +val string_node_cost_of_length : int -> Gas_limit_repr.cost +val bytes_node_cost : MBytes.t -> Gas_limit_repr.cost +val bytes_node_cost_of_length : int -> Gas_limit_repr.cost +val prim_node_cost_nonrec : expr list -> annot -> Gas_limit_repr.cost +val prim_node_cost_nonrec_of_length : int -> annot -> Gas_limit_repr.cost +val seq_node_cost_nonrec : expr list -> Gas_limit_repr.cost +val seq_node_cost_nonrec_of_length : int -> Gas_limit_repr.cost + +val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult + +val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult + +val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml new file mode 100644 index 000000000..e0ec2ff63 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml @@ -0,0 +1,84 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script + + +(* ---- Error definitions ---------------------------------------------------*) + +(* Auxiliary types for error documentation *) +type namespace = Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace +type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind +type unparsed_stack_ty = (Script.expr * Script.annot) list +type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list + +(* Structure errors *) +type error += Invalid_arity of Script.location * prim * int * int +type error += Invalid_namespace of Script.location * prim * namespace * namespace +type error += Invalid_primitive of Script.location * prim list * prim +type error += Invalid_kind of Script.location * kind list * kind +type error += Missing_field of prim +type error += Duplicate_field of Script.location * prim +type error += Unexpected_big_map of Script.location +type error += Unexpected_operation of Script.location + +(* Instruction typing errors *) +type error += Fail_not_in_tail_position of Script.location +type error += Undefined_binop : Script.location * prim * Script.expr * Script.expr -> error +type error += Undefined_unop : Script.location * prim * Script.expr -> error +type error += Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error +type error += Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error +type error += Unmatched_branches : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error +type error += Self_in_lambda of Script.location +type error += Bad_stack_length +type error += Bad_stack_item of int +type error += Inconsistent_annotations of string * string +type error += Inconsistent_type_annotations : Script.location * Script.expr * Script.expr -> error +type error += Inconsistent_field_annotations of string * string +type error += Unexpected_annotation of Script.location +type error += Ungrouped_annotations of Script.location +type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error +type error += Invalid_map_block_fail of Script.location +type error += Invalid_iter_body : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error +type error += Type_too_large : Script.location * int * int -> error + +(* Value typing errors *) +type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error +type error += Invalid_contract of Script.location * Contract.t +type error += Comparable_type_expected : Script.location * Script.expr -> error +type error += Inconsistent_types : Script.expr * Script.expr -> error +type error += Unordered_map_keys of Script.location * Script.expr +type error += Unordered_set_values of Script.location * Script.expr +type error += Duplicate_map_keys of Script.location * Script.expr +type error += Duplicate_set_values of Script.location * Script.expr + +(* Toplevel errors *) +type error += Ill_typed_data : string option * Script.expr * Script.expr -> error +type error += Ill_formed_type of string option * Script.expr * Script.location +type error += Ill_typed_contract : Script.expr * type_map -> error + +(* Gas related errors *) +type error += Cannot_serialize_error diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml new file mode 100644 index 000000000..10347b6a7 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml @@ -0,0 +1,622 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script +open Script_tc_errors + +(* Helpers for encoding *) +let type_map_enc = + let open Data_encoding in + let stack_enc = list (tup2 Script.expr_encoding (list string)) in + list + (conv + (fun (loc, (bef, aft)) -> (loc, bef, aft)) + (fun (loc, bef, aft) -> (loc, (bef, aft))) + (obj3 + (req "location" Script.location_encoding) + (req "stack_before" stack_enc) + (req "stack_after" stack_enc))) + +let stack_ty_enc = + let open Data_encoding in + (list + (obj2 + (req "type" Script.expr_encoding) + (dft "annots" (list string) []))) + +(* main registration *) +let () = + let open Data_encoding in + let located enc = + merge_objs + (obj1 (req "location" Script.location_encoding)) + enc in + let arity_enc = + int8 in + let namespace_enc = + def "primitiveNamespace" + ~title: "Primitive namespace" + ~description: + "One of the three possible namespaces of primitive \ + (data constructor, type name or instruction)." @@ + string_enum [ "type", Type_namespace ; + "constant", Constant_namespace ; + "instruction", Instr_namespace ] in + let kind_enc = + def "expressionKind" + ~title: "Expression kind" + ~description: + "One of the four possible kinds of expression \ + (integer, string, primitive application or sequence)." @@ + string_enum [ "integer", Int_kind ; + "string", String_kind ; + "bytes", Bytes_kind ; + "primitiveApplication", Prim_kind ; + "sequence", Seq_kind ] in + (* -- Structure errors ---------------------- *) + (* Invalid arity *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_arity" + ~title: "Invalid arity" + ~description: + "In a script or data expression, a primitive was applied \ + to an unsupported number of arguments." + (located (obj3 + (req "primitive_name" Script.prim_encoding) + (req "expected_arity" arity_enc) + (req "wrong_arity" arity_enc))) + (function + | Invalid_arity (loc, name, exp, got) -> + Some (loc, (name, exp, got)) + | _ -> None) + (fun (loc, (name, exp, got)) -> + Invalid_arity (loc, name, exp, got)) ; + (* Missing field *) + register_error_kind + `Permanent + ~id:"michelson_v1.missing_script_field" + ~title:"Script is missing a field (parse error)" + ~description: + "When parsing script, a field was expected, but not provided" + (obj1 (req "prim" prim_encoding)) + (function Missing_field prim -> Some prim | _ -> None) + (fun prim -> Missing_field prim) ; + (* Invalid primitive *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive" + ~title: "Invalid primitive" + ~description: + "In a script or data expression, a primitive was unknown." + (located (obj2 + (dft "expected_primitive_names" (list prim_encoding) []) + (req "wrong_primitive_name" prim_encoding))) + (function + | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) + | _ -> None) + (fun (loc, (exp, got)) -> + Invalid_primitive (loc, exp, got)) ; + (* Invalid kind *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_expression_kind" + ~title: "Invalid expression kind" + ~description: + "In a script or data expression, an expression was of the wrong kind \ + (for instance a string where only a primitive applications can appear)." + (located (obj2 + (req "expected_kinds" (list kind_enc)) + (req "wrong_kind" kind_enc))) + (function + | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) + | _ -> None) + (fun (loc, (exp, got)) -> + Invalid_kind (loc, exp, got)) ; + (* Invalid namespace *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive_namespace" + ~title: "Invalid primitive namespace" + ~description: + "In a script or data expression, a primitive was of the wrong namespace." + (located (obj3 + (req "primitive_name" prim_encoding) + (req "expected_namespace" namespace_enc) + (req "wrong_namespace" namespace_enc))) + (function + | Invalid_namespace (loc, name, exp, got) -> Some (loc, (name, exp, got)) + | _ -> None) + (fun (loc, (name, exp, got)) -> + Invalid_namespace (loc, name, exp, got)) ; + (* Duplicate field *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_script_field" + ~title: "Script has a duplicated field (parse error)" + ~description: + "When parsing script, a field was found more than once" + (obj2 + (req "loc" location_encoding) + (req "prim" prim_encoding)) + (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None) + (fun (loc, prim) -> Duplicate_field (loc, prim)) ; + (* Unexpected big_map *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_bigmap" + ~title: "Big map in unauthorized position (type error)" + ~description: + "When parsing script, a big_map type was found somewhere else \ + than in the left component of the toplevel storage pair." + (obj1 + (req "loc" location_encoding)) + (function Unexpected_big_map loc -> Some loc | _ -> None) + (fun loc -> Unexpected_big_map loc) ; + (* Unexpected operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_operation" + ~title: "Big map in unauthorized position (type error)" + ~description: + "When parsing script, a operation type was found \ + in the storage or parameter field." + (obj1 + (req "loc" location_encoding)) + (function Unexpected_operation loc -> Some loc | _ -> None) + (fun loc -> Unexpected_operation loc) ; + (* -- Value typing errors ---------------------- *) + (* Unordered map keys *) + register_error_kind + `Permanent + ~id:"michelson_v1.unordered_map_literal" + ~title:"Invalid map key order" + ~description:"Map keys must be in strictly increasing order" + (obj2 + (req "location" Script.location_encoding) + (req "item" Script.expr_encoding)) + (function + | Unordered_map_keys (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Unordered_map_keys (loc, expr)); + (* Duplicate map keys *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_map_keys" + ~title:"Duplicate map keys" + ~description:"Map literals cannot contain duplicated keys" + (obj2 + (req "location" Script.location_encoding) + (req "item" Script.expr_encoding)) + (function + | Duplicate_map_keys (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Duplicate_map_keys (loc, expr)); + (* Unordered set values *) + register_error_kind + `Permanent + ~id:"michelson_v1.unordered_set_literal" + ~title:"Invalid set value order" + ~description:"Set values must be in strictly increasing order" + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Unordered_set_values (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Unordered_set_values (loc, expr)); + (* Duplicate set values *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_set_values_in_literal" + ~title:"Sets literals cannot contain duplicate elements" + ~description:"Set literals cannot contain duplicate elements, \ + but a duplicae was found while parsing." + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Duplicate_set_values (loc, expr) -> Some (loc, expr) + | _ -> None) + (fun (loc, expr) -> Duplicate_set_values (loc, expr)); + (* -- Instruction typing errors ------------- *) + (* Fail not in tail position *) + register_error_kind + `Permanent + ~id:"michelson_v1.fail_not_in_tail_position" + ~title: "FAIL not in tail position" + ~description: + "There is non trivial garbage code after a FAIL instruction." + (located empty) + (function + | Fail_not_in_tail_position loc -> Some (loc, ()) + | _ -> None) + (fun (loc, ()) -> + Fail_not_in_tail_position loc) ; + (* Undefined binary operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.undefined_binop" + ~title: "Undefined binop" + ~description: + "A binary operation is called on operands of types \ + over which it is not defined." + (located (obj3 + (req "operator_name" prim_encoding) + (req "wrong_left_operand_type" Script.expr_encoding) + (req "wrong_right_operand_type" Script.expr_encoding))) + (function + | Undefined_binop (loc, n, tyl, tyr) -> + Some (loc, (n, tyl, tyr)) + | _ -> None) + (fun (loc, (n, tyl, tyr)) -> + Undefined_binop (loc, n, tyl, tyr)) ; + (* Undefined unary operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.undefined_unop" + ~title: "Undefined unop" + ~description: + "A unary operation is called on an operand of type \ + over which it is not defined." + (located (obj2 + (req "operator_name" prim_encoding) + (req "wrong_operand_type" Script.expr_encoding))) + (function + | Undefined_unop (loc, n, ty) -> + Some (loc, (n, ty)) + | _ -> None) + (fun (loc, (n, ty)) -> + Undefined_unop (loc, n, ty)) ; + (* Bad return *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_return" + ~title: "Bad return" + ~description: + "Unexpected stack at the end of a lambda or script." + (located (obj2 + (req "expected_return_type" Script.expr_encoding) + (req "wrong_stack_type" stack_ty_enc))) + (function + | Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) + | _ -> None) + (fun (loc, (ty, sty)) -> + Bad_return (loc, sty, ty)) ; + (* Bad stack *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_stack" + ~title: "Bad stack" + ~description: + "The stack has an unexpected length or contents." + (located (obj3 + (req "primitive_name" prim_encoding) + (req "relevant_stack_portion" int16) + (req "wrong_stack_type" stack_ty_enc))) + (function + | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) + | _ -> None) + (fun (loc, (name, s, sty)) -> + Bad_stack (loc, name, s, sty)) ; + (* Inconsistent annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_annotations" + ~title:"Annotations inconsistent between branches" + ~description:"The annotations on two types could not be merged" + (obj2 + (req "annot1" string) + (req "annot2" string)) + (function Inconsistent_annotations (annot1, annot2) -> Some (annot1, annot2) + | _ -> None) + (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ; + (* Inconsistent field annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_field_annotations" + ~title:"Annotations for field accesses is inconsistent" + ~description:"The specified field does not match the field annotation in the type" + (obj2 + (req "annot1" string) + (req "annot2" string)) + (function Inconsistent_field_annotations (annot1, annot2) -> Some (annot1, annot2) + | _ -> None) + (fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ; + (* Inconsistent type annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_type_annotations" + ~title:"Types contain inconsistent annotations" + ~description:"The two types contain annotations that do not match" + (located (obj2 + (req "type1" Script.expr_encoding) + (req "type2" Script.expr_encoding))) + (function + | Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (ty1, ty2)) + | _ -> None) + (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ; + (* Unexpected annotation *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_annotation" + ~title:"An annotation was encountered where no annotation is expected" + ~description:"A node in the syntax tree was impropperly annotated" + (located empty) + (function Unexpected_annotation loc -> Some (loc, ()) + | _ -> None) + (fun (loc, ()) -> Unexpected_annotation loc); + (* Ungrouped annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.ungrouped_annotations" + ~title:"Annotations of the same kind were found spread apart" + ~description:"Annotations of the same kind must be grouped" + (located empty) + (function Ungrouped_annotations loc -> Some (loc, ()) + | _ -> None) + (fun (loc, ()) -> Ungrouped_annotations loc); + (* Unmatched branches *) + register_error_kind + `Permanent + ~id:"michelson_v1.unmatched_branches" + ~title: "Unmatched branches" + ~description: + "At the join point at the end of two code branches \ + the stacks have inconsistent lengths or contents." + (located (obj2 + (req "first_stack_type" stack_ty_enc) + (req "other_stack_type" stack_ty_enc))) + (function + | Unmatched_branches (loc, stya, styb) -> + Some (loc, (stya, styb)) + | _ -> None) + (fun (loc, (stya, styb)) -> + Unmatched_branches (loc, stya, styb)) ; + (* Bad stack item *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_stack_item" + ~title: "Bad stack item" + ~description: + "The type of a stack item is unexpected \ + (this error is always accompanied by a more precise one)." + (obj1 (req "item_level" int16)) + (function + | Bad_stack_item n -> Some n + | _ -> None) + (fun n -> + Bad_stack_item n) ; + (* SELF in lambda *) + register_error_kind + `Permanent + ~id:"michelson_v1.self_in_lambda" + ~title: "SELF instruction in lambda" + ~description: + "A SELF instruction was encountered in a lambda expression." + (located empty) + (function + | Self_in_lambda loc -> Some (loc, ()) + | _ -> None) + (fun (loc, ()) -> + Self_in_lambda loc) ; + (* Bad stack length *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_stack_lengths" + ~title: "Inconsistent stack lengths" + ~description: + "A stack was of an unexpected length \ + (this error is always in the context of a located error)." + empty + (function + | Bad_stack_length -> Some () + | _ -> None) + (fun () -> + Bad_stack_length) ; + (* -- Value typing errors ------------------- *) + (* Invalid constant *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_constant" + ~title: "Invalid constant" + ~description: + "A data expression was invalid for its expected type." + (located (obj2 + (req "expected_type" Script.expr_encoding) + (req "wrong_expression" Script.expr_encoding))) + (function + | Invalid_constant (loc, expr, ty) -> + Some (loc, (ty, expr)) + | _ -> None) + (fun (loc, (ty, expr)) -> + Invalid_constant (loc, expr, ty)) ; + (* Invalid contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_contract" + ~title: "Invalid contract" + ~description: + "A script or data expression references a contract that does not \ + exist or assumes a wrong type for an existing contract." + (located (obj1 (req "contract" Contract.encoding))) + (function + | Invalid_contract (loc, c) -> + Some (loc, c) + | _ -> None) + (fun (loc, c) -> + Invalid_contract (loc, c)) ; + (* Comparable type expected *) + register_error_kind + `Permanent + ~id:"michelson_v1.comparable_type_expected" + ~title: "Comparable type expected" + ~description: + "A non comparable type was used in a place where \ + only comparable types are accepted." + (located (obj1 (req "wrong_type" Script.expr_encoding))) + (function + | Comparable_type_expected (loc, ty) -> Some (loc, ty) + | _ -> None) + (fun (loc, ty) -> + Comparable_type_expected (loc, ty)) ; + (* Inconsistent types *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_types" + ~title: "Inconsistent types" + ~description: + "This is the basic type clash error, \ + that appears in several places where the equality of \ + two types have to be proven, it is always accompanied \ + with another error that provides more context." + (obj2 + (req "first_type" Script.expr_encoding) + (req "other_type" Script.expr_encoding)) + (function + | Inconsistent_types (tya, tyb) -> Some (tya, tyb) + | _ -> None) + (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ; + (* -- Instruction typing errors ------------------- *) + (* Invalid map body *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_map_body" + ~title: "Invalid map body" + ~description: + "The body of a map block did not match the expected type" + (obj2 + (req "loc" Script.location_encoding) + (req "body_type" stack_ty_enc)) + (function + | Invalid_map_body (loc, stack) -> Some (loc, stack) + | _ -> None) + (fun (loc, stack) -> Invalid_map_body (loc, stack)) ; + (* Invalid map block FAIL *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_map_block_fail" + ~title:"FAIL instruction occurred as body of map block" + ~description:"FAIL cannot be the only instruction in the body. \ + The propper type of the return list cannot be inferred." + (obj1 (req "loc" Script.location_encoding)) + (function + | Invalid_map_block_fail loc -> Some loc + | _ -> None) + (fun loc -> Invalid_map_block_fail loc) ; + (* Invalid ITER body *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_iter_body" + ~title:"ITER body returned wrong stack type" + ~description:"The body of an ITER instruction \ + must result in the same stack type as before \ + the ITER." + (obj3 + (req "loc" Script.location_encoding) + (req "bef_stack" stack_ty_enc) + (req "aft_stack" stack_ty_enc)) + (function + | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) + | _ -> None) + (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ; + (* Type too large *) + register_error_kind + `Permanent + ~id:"michelson_v1.type_too_large" + ~title:"Stack item type too large" + ~description:"An instruction generated a type larger than the limit." + (obj3 + (req "loc" Script.location_encoding) + (req "type_size" uint16) + (req "maximum_type_size" uint16)) + (function + | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) + | _ -> None) + (fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ; + (* -- Toplevel errors ------------------- *) + (* Ill typed data *) + register_error_kind + `Permanent + ~id:"michelson_v1.ill_typed_data" + ~title: "Ill typed data" + ~description: + "The toplevel error thrown when trying to typecheck \ + a data expression against a given type \ + (always followed by more precise errors)." + (obj3 + (opt "identifier" string) + (req "expected_type" Script.expr_encoding) + (req "ill_typed_expression" Script.expr_encoding)) + (function + | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) + | _ -> None) + (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ; + (* Ill formed type *) + register_error_kind + `Permanent + ~id:"michelson_v1.ill_formed_type" + ~title: "Ill formed type" + ~description: + "The toplevel error thrown when trying to parse a type expression \ + (always followed by more precise errors)." + (obj3 + (opt "identifier" string) + (req "ill_formed_expression" Script.expr_encoding) + (req "location" Script.location_encoding)) + (function + | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) + | _ -> None) + (fun (name, expr, loc) -> + Ill_formed_type (name, expr, loc)) ; + (* Ill typed contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.ill_typed_contract" + ~title: "Ill typed contract" + ~description: + "The toplevel error thrown when trying to typecheck \ + a contract code against given input, output and storage types \ + (always followed by more precise errors)." + (obj2 + (req "ill_typed_code" Script.expr_encoding) + (req "type_map" type_map_enc)) + (function + | Ill_typed_contract (expr, type_map) -> + Some (expr, type_map) + | _ -> None) + (fun (expr, type_map) -> + Ill_typed_contract (expr, type_map)) ; + (* Cannot serialize error *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_error" + ~title:"Not enough gas to serialize error" + ~description:"The error was too big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_error -> Some () | _ -> None) + (fun () -> Cannot_serialize_error) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml new file mode 100644 index 000000000..8c6a48d32 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml @@ -0,0 +1,64 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Z.t + +let compare = Z.compare + +let of_int64 = Z.of_int64 + +let of_string x = + match Time_repr.of_notation x with + | None -> + begin try Some (Z.of_string x) + with _ -> None + end + | Some time -> + Some (of_int64 (Time_repr.to_seconds time)) + +let to_notation x = + try + let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in + if String.equal notation "out_of_range" + then None + else Some notation + with _ -> None + +let to_num_str = Z.to_string + +let to_string x = + match to_notation x with + | None -> to_num_str x + | Some s -> s + +let diff x y = Script_int_repr.of_zint @@ Z.sub x y + +let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta) + +let add_delta t delta = + Z.add t (Script_int_repr.to_zint delta) + +let to_zint x = x +let of_zint x = x diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli new file mode 100644 index 000000000..73496c369 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli @@ -0,0 +1,49 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Script_int_repr + +type t + +val of_int64 : int64 -> t + +val compare : t -> t -> int + +(* Convert a timestamp to a notation if possible *) +val to_notation : t -> string option +(* Convert a timestamp to a string representation of the seconds *) +val to_num_str : t -> string +(* Convert to a notation if possible, or num if not *) +val to_string : t -> string +val of_string : string -> t option + +val diff : t -> t -> z num + +val add_delta : t -> z num -> t + +val sub_delta : t -> z num -> t + +val to_zint : t -> Z.t +val of_zint : Z.t -> t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml new file mode 100644 index 000000000..7656fc44a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml @@ -0,0 +1,401 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_int + +(* ---- Auxiliary types -----------------------------------------------------*) + +type var_annot = [ `Var_annot of string ] +type type_annot = [ `Type_annot of string ] +type field_annot = [ `Field_annot of string ] + +type annot = [ var_annot | type_annot | field_annot ] + +type 'ty comparable_ty = + | Int_key : type_annot option -> (z num) comparable_ty + | Nat_key : type_annot option -> (n num) comparable_ty + | String_key : type_annot option -> string comparable_ty + | Bytes_key : type_annot option -> MBytes.t comparable_ty + | Mutez_key : type_annot option -> Tez.t comparable_ty + | Bool_key : type_annot option -> bool comparable_ty + | Key_hash_key : type_annot option -> public_key_hash comparable_ty + | Timestamp_key : type_annot option -> Script_timestamp.t comparable_ty + | Address_key : type_annot option -> Contract.t comparable_ty + + +module type Boxed_set = sig + type elt + module OPS : S.SET with type elt = elt + val boxed : OPS.t + val size : int +end + +type 'elt set = (module Boxed_set with type elt = 'elt) + +module type Boxed_map = sig + type key + type value + val key_ty : key comparable_ty + module OPS : S.MAP with type key = key + val boxed : value OPS.t * int +end + +type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value) + +type ('arg, 'storage) script = + { code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ; + arg_type : 'arg ty ; + storage : 'storage ; + storage_type : 'storage ty } + +and ('a, 'b) pair = 'a * 'b + +and ('a, 'b) union = L of 'a | R of 'b + +and end_of_stack = unit + +and ('arg, 'ret) lambda = + Lam of ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.expr + +and 'arg typed_contract = + 'arg ty * Contract.t + +and 'ty ty = + | Unit_t : type_annot option -> unit ty + | Int_t : type_annot option -> z num ty + | Nat_t : type_annot option -> n num ty + | Signature_t : type_annot option -> signature ty + | String_t : type_annot option -> string ty + | Bytes_t : type_annot option -> MBytes.t ty + | Mutez_t : type_annot option -> Tez.t ty + | Key_hash_t : type_annot option -> public_key_hash ty + | Key_t : type_annot option -> public_key ty + | Timestamp_t : type_annot option -> Script_timestamp.t ty + | Address_t : type_annot option -> Contract.t ty + | Bool_t : type_annot option -> bool ty + | Pair_t : + ('a ty * field_annot option * var_annot option) * + ('b ty * field_annot option * var_annot option) * + type_annot option -> ('a, 'b) pair ty + | Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) union ty + | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty + | Option_t : ('v ty * field_annot option) * field_annot option * type_annot option -> 'v option ty + | List_t : 'v ty * type_annot option -> 'v list ty + | Set_t : 'v comparable_ty * type_annot option -> 'v set ty + | Map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) map ty + | Big_map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) big_map ty + | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty + | Operation_t : type_annot option -> packed_internal_operation ty + +and 'ty stack_ty = + | Item_t : 'ty ty * 'rest stack_ty * var_annot option -> ('ty * 'rest) stack_ty + | Empty_t : end_of_stack stack_ty + +and ('key, 'value) big_map = { diff : ('key, 'value option) map ; + key_type : 'key ty ; + value_type : 'value ty } + +(* ---- Instructions --------------------------------------------------------*) + +(* The low-level, typed instructions, as a GADT whose parameters + encode the typing rules. The left parameter is the typed shape of + the stack before the instruction, the right one the shape + after. Any program whose construction is accepted by OCaml's + type-checker is guaranteed to be type-safe. Overloadings of the + concrete syntax are already resolved in this representation, either + by using different constructors or type witness parameters. *) +and ('bef, 'aft) instr = + (* stack ops *) + | Drop : + (_ * 'rest, 'rest) instr + | Dup : + ('top * 'rest, 'top * ('top * 'rest)) instr + | Swap : + ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr + | Const : 'ty -> + ('rest, ('ty * 'rest)) instr + (* pairs *) + | Cons_pair : + (('car * ('cdr * 'rest)), (('car, 'cdr) pair * 'rest)) instr + | Car : + (('car, _) pair * 'rest, 'car * 'rest) instr + | Cdr : + ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr + (* options *) + | Cons_some : + ('v * 'rest, 'v option * 'rest) instr + | Cons_none : 'a ty -> + ('rest, 'a option * 'rest) instr + | If_none : ('bef, 'aft) descr * ('a * 'bef, 'aft) descr -> + ('a option * 'bef, 'aft) instr + (* unions *) + | Left : + ('l * 'rest, (('l, 'r) union * 'rest)) instr + | Right : + ('r * 'rest, (('l, 'r) union * 'rest)) instr + | If_left : ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr -> + (('l, 'r) union * 'bef, 'aft) instr + (* lists *) + | Cons_list : + ('a * ('a list * 'rest), ('a list * 'rest)) instr + | Nil : + ('rest, ('a list * 'rest)) instr + | If_cons : ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr -> + ('a list * 'bef, 'aft) instr + | List_map : ('a * 'rest, 'b * 'rest) descr -> + ('a list * 'rest, 'b list * 'rest) instr + | List_iter : ('a * 'rest, 'rest) descr -> + ('a list * 'rest, 'rest) instr + | List_size : ('a list * 'rest, n num * 'rest) instr + (* sets *) + | Empty_set : 'a comparable_ty -> + ('rest, 'a set * 'rest) instr + | Set_iter : ('a * 'rest, 'rest) descr -> + ('a set * 'rest, 'rest) instr + | Set_mem : + ('elt * ('elt set * 'rest), bool * 'rest) instr + | Set_update : + ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr + | Set_size : ('a set * 'rest, n num * 'rest) instr + (* maps *) + | Empty_map : 'a comparable_ty * 'v ty -> + ('rest, ('a, 'v) map * 'rest) instr + | Map_map : (('a * 'v) * 'rest, 'r * 'rest) descr -> + (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr + | Map_iter : (('a * 'v) * 'rest, 'rest) descr -> + (('a, 'v) map * 'rest, 'rest) instr + | Map_mem : + ('a * (('a, 'v) map * 'rest), bool * 'rest) instr + | Map_get : + ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr + | Map_update : + ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr + | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr + (* big maps *) + | Big_map_mem : + ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr + | Big_map_get : + ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr + | Big_map_update : + ('key * ('value option * (('key, 'value) big_map * 'rest)), ('key, 'value) big_map * 'rest) instr + (* string operations *) + | Concat_string : + (string list * 'rest, string * 'rest) instr + | Concat_string_pair : + (string * (string * 'rest), string * 'rest) instr + | Slice_string : + (n num * (n num * (string * 'rest)), string option * 'rest) instr + | String_size : + (string * 'rest, n num * 'rest) instr + (* bytes operations *) + | Concat_bytes : + (MBytes.t list * 'rest, MBytes.t * 'rest) instr + | Concat_bytes_pair : + (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr + | Slice_bytes : + (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr + | Bytes_size : + (MBytes.t * 'rest, n num * 'rest) instr + (* timestamp operations *) + | Add_seconds_to_timestamp : + (z num * (Script_timestamp.t * 'rest), + Script_timestamp.t * 'rest) instr + | Add_timestamp_to_seconds : + (Script_timestamp.t * (z num * 'rest), + Script_timestamp.t * 'rest) instr + | Sub_timestamp_seconds : + (Script_timestamp.t * (z num * 'rest), + Script_timestamp.t * 'rest) instr + | Diff_timestamps : + (Script_timestamp.t * (Script_timestamp.t * 'rest), + z num * 'rest) instr + (* currency operations *) + (* TODO: we can either just have conversions to/from integers and + do all operations on integers, or we need more operations on + Tez. Also Sub_tez should return Tez.t option (if negative) and *) + | Add_tez : + (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Sub_tez : + (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Mul_teznat : + (Tez.t * (n num * 'rest), Tez.t * 'rest) instr + | Mul_nattez : + (n num * (Tez.t * 'rest), Tez.t * 'rest) instr + | Ediv_teznat : + (Tez.t * (n num * 'rest), ((Tez.t, Tez.t) pair) option * 'rest) instr + | Ediv_tez : + (Tez.t * (Tez.t * 'rest), ((n num, Tez.t) pair) option * 'rest) instr + (* boolean operations *) + | Or : + (bool * (bool * 'rest), bool * 'rest) instr + | And : + (bool * (bool * 'rest), bool * 'rest) instr + | Xor : + (bool * (bool * 'rest), bool * 'rest) instr + | Not : + (bool * 'rest, bool * 'rest) instr + (* integer operations *) + | Is_nat : + (z num * 'rest, n num option * 'rest) instr + | Neg_nat : + (n num * 'rest, z num * 'rest) instr + | Neg_int : + (z num * 'rest, z num * 'rest) instr + | Abs_int : + (z num * 'rest, n num * 'rest) instr + | Int_nat : + (n num * 'rest, z num * 'rest) instr + | Add_intint : + (z num * (z num * 'rest), z num * 'rest) instr + | Add_intnat : + (z num * (n num * 'rest), z num * 'rest) instr + | Add_natint : + (n num * (z num * 'rest), z num * 'rest) instr + | Add_natnat : + (n num * (n num * 'rest), n num * 'rest) instr + | Sub_int : + ('s num * ('t num * 'rest), z num * 'rest) instr + | Mul_intint : + (z num * (z num * 'rest), z num * 'rest) instr + | Mul_intnat : + (z num * (n num * 'rest), z num * 'rest) instr + | Mul_natint : + (n num * (z num * 'rest), z num * 'rest) instr + | Mul_natnat : + (n num * (n num * 'rest), n num * 'rest) instr + | Ediv_intint : + (z num * (z num * 'rest), ((z num, n num) pair) option * 'rest) instr + | Ediv_intnat : + (z num * (n num * 'rest), ((z num, n num) pair) option * 'rest) instr + | Ediv_natint : + (n num * (z num * 'rest), ((z num, n num) pair) option * 'rest) instr + | Ediv_natnat : + (n num * (n num * 'rest), ((n num, n num) pair) option * 'rest) instr + | Lsl_nat : + (n num * (n num * 'rest), n num * 'rest) instr + | Lsr_nat : + (n num * (n num * 'rest), n num * 'rest) instr + | Or_nat : + (n num * (n num * 'rest), n num * 'rest) instr + | And_nat : + (n num * (n num * 'rest), n num * 'rest) instr + | And_int_nat : + (z num * (n num * 'rest), n num * 'rest) instr + | Xor_nat : + (n num * (n num * 'rest), n num * 'rest) instr + | Not_nat : + (n num * 'rest, z num * 'rest) instr + | Not_int : + (z num * 'rest, z num * 'rest) instr + (* control *) + | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> + ('bef, 'aft) instr + | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> + (bool * 'bef, 'aft) instr + | Loop : ('rest, bool * 'rest) descr -> + (bool * 'rest, 'rest) instr + | Loop_left : ('a * 'rest, ('a, 'b) union * 'rest) descr -> + (('a, 'b) union * 'rest, 'b * 'rest) instr + | Dip : ('bef, 'aft) descr -> + ('top * 'bef, 'top * 'aft) instr + | Exec : + ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Lambda : ('arg, 'ret) lambda -> + ('rest, ('arg, 'ret) lambda * 'rest) instr + | Failwith : + 'a ty -> ('a * 'rest, 'aft) instr + | Nop : + ('rest, 'rest) instr + (* comparison *) + | Compare : 'a comparable_ty -> + ('a * ('a * 'rest), z num * 'rest) instr + (* comparators *) + | Eq : + (z num * 'rest, bool * 'rest) instr + | Neq : + (z num * 'rest, bool * 'rest) instr + | Lt : + (z num * 'rest, bool * 'rest) instr + | Gt : + (z num * 'rest, bool * 'rest) instr + | Le : + (z num * 'rest, bool * 'rest) instr + | Ge : + (z num * 'rest, bool * 'rest) instr + + (* protocol *) + | Address : + (_ typed_contract * 'rest, Contract.t * 'rest) instr + | Contract : 'p ty -> + (Contract.t * 'rest, 'p typed_contract option * 'rest) instr + | Transfer_tokens : + ('arg * (Tez.t * ('arg typed_contract * 'rest)), packed_internal_operation * 'rest) instr + | Create_account : + (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), + packed_internal_operation * (Contract.t * 'rest)) instr + | Implicit_account : + (public_key_hash * 'rest, unit typed_contract * 'rest) instr + | Create_contract : 'g ty * 'p ty * ('p * 'g, packed_internal_operation list * 'g) lambda -> + (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))), + packed_internal_operation * (Contract.t * 'rest)) instr + | Set_delegate : + (public_key_hash option * 'rest, packed_internal_operation * 'rest) instr + | Now : + ('rest, Script_timestamp.t * 'rest) instr + | Balance : + ('rest, Tez.t * 'rest) instr + | Check_signature : + (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr + | Hash_key : + (public_key * 'rest, public_key_hash * 'rest) instr + | Pack : 'a ty -> + ('a * 'rest, MBytes.t * 'rest) instr + | Unpack : 'a ty -> + (MBytes.t * 'rest, 'a option * 'rest) instr + | Blake2b : + (MBytes.t * 'rest, MBytes.t * 'rest) instr + | Sha256 : + (MBytes.t * 'rest, MBytes.t * 'rest) instr + | Sha512 : + (MBytes.t * 'rest, MBytes.t * 'rest) instr + | Steps_to_quota : (* TODO: check that it always returns a nat *) + ('rest, n num * 'rest) instr + | Source : + ('rest, Contract.t * 'rest) instr + | Sender : + ('rest, Contract.t * 'rest) instr + | Self : 'p ty -> + ('rest, 'p typed_contract * 'rest) instr + | Amount : + ('rest, Tez.t * 'rest) instr + +and ('bef, 'aft) descr = + { loc : Script.location ; + bef : 'bef stack_ty ; + aft : 'aft stack_ty ; + instr : ('bef, 'aft) instr } + +type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml new file mode 100644 index 000000000..4a18d2a6a --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml @@ -0,0 +1,139 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Random number generation *) + +type seed = B of State_hash.t +type t = T of State_hash.t +type sequence = S of State_hash.t +type nonce = MBytes.t + +let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length + +let init = "Laissez-faire les proprietaires." +let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000') + +let state_hash_encoding = + let open Data_encoding in + conv + State_hash.to_bytes + State_hash.of_bytes_exn + (Fixed.bytes Nonce_hash.size) + +let seed_encoding = + let open Data_encoding in + conv + (fun (B b) -> b) + (fun b -> B b) + state_hash_encoding + +let empty = B (State_hash.hash_bytes [MBytes.of_string init]) + +let nonce (B state) nonce = + B (State_hash.hash_bytes ( [State_hash.to_bytes state; nonce] )) + +let initialize_new (B state) append = + T (State_hash.hash_bytes + (State_hash.to_bytes state :: zero_bytes :: append )) + +let xor_higher_bits i b = + let higher = MBytes.get_int32 b 0 in + let r = Int32.logxor higher i in + let res = MBytes.copy b in + MBytes.set_int32 res 0 r; + res + +let sequence (T state) n = + State_hash.to_bytes state + |> xor_higher_bits n + |> (fun b -> S (State_hash.hash_bytes [b])) + +let take (S state) = + let b = State_hash.to_bytes state in + let h = State_hash.hash_bytes [b] in + (State_hash.to_bytes h, S h) + +let take_int32 s bound = + if Compare.Int32.(bound <= 0l) + then invalid_arg "Seed_repr.take_int32" (* FIXME *) + else + let rec loop s = + let bytes, s = take s in + let r = Int32.abs (MBytes.get_int32 bytes 0) in + let drop_if_over = + Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in + if Compare.Int32.(r >= drop_if_over) + then loop s + else + let v = Int32.rem r bound in + v, s + in + loop s + +type error += Unexpected_nonce_length (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"unexpected_nonce_length" + ~title:"Unexpected nonce length" + ~description:"Nonce length is incorrect." + ~pp:(fun ppf () -> + Format.fprintf ppf "Nonce length is not %i bytes long as it should." + Constants_repr.nonce_length) + Data_encoding.empty + (function Unexpected_nonce_length -> Some () | _ -> None) + (fun () -> Unexpected_nonce_length) + +let make_nonce nonce = + if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) + then error Unexpected_nonce_length + else ok nonce + +let hash nonce = Nonce_hash.hash_bytes [nonce] + +let check_hash nonce hash = + Compare.Int.(MBytes.length nonce = Constants_repr.nonce_length) + && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash + +let nonce_hash_key_part = Nonce_hash.to_path + +let initial_nonce_0 = zero_bytes + +let initial_nonce_hash_0 = + hash initial_nonce_0 + +let deterministic_seed seed = nonce seed zero_bytes + +let initial_seeds n = + let rec loop acc elt i = + if Compare.Int.(i = 1) then + List.rev (elt :: acc) + else + loop + (elt :: acc) + (deterministic_seed elt) + (i-1) in + loop [] (B (State_hash.hash_bytes [])) n diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli new file mode 100644 index 000000000..ae9827c8e --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli @@ -0,0 +1,99 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Random number generation + + This is not expected to be a good cryptographic random number + generator. In particular this is supposed to be used in situations + where the seed is a globaly known information. + + The only expected property is: It should be difficult to find a + seed such that the generated sequence is a given one. *) + + +(** {2 Random Generation} ****************************************************) + +(** The state of the random number generator *) +type t + +(** A random seed, to derive random sequences from *) +type seed + +(** A random sequence, to derive random values from *) +type sequence + +(** [initialize_new state ident] returns a new generator *) +val initialize_new : seed -> MBytes.t list -> t + +(** [sequence state n] prepares the n-th sequence of a state *) +val sequence : t -> int32 -> sequence + +(** Generates the next random value in the sequence *) +val take : sequence -> MBytes.t * sequence + +(** Generates the next random value as a bounded [int32] *) +val take_int32 : sequence -> int32 -> int32 * sequence + +(** {2 Predefined seeds} *****************************************************) + +val empty : seed + +(** Returns a new seed by hashing the one passed with a constant. *) +val deterministic_seed : seed -> seed + +(** [intial_seeds n] generates the first [n] seeds for which there are no nonces. + The first seed is a constant value. The kth seed is the hash of seed (k-1) + concatenated with a constant. *) +val initial_seeds : int -> seed list + +(** {2 Entropy} **************************************************************) + +(** A nonce for adding entropy to the generator *) +type nonce + +(** Add entropy to the seed generator *) +val nonce : seed -> nonce -> seed + +(** Use a byte sequence as a nonce *) +val make_nonce : MBytes.t -> nonce tzresult + +(** Compute the has of a nonce *) +val hash : nonce -> Nonce_hash.t + +(** [check_hash nonce hash] is true if the nonce correspond to the hash *) +val check_hash : nonce -> Nonce_hash.t -> bool + +(** For using nonce hashes as keys in the hierarchical database *) +val nonce_hash_key_part : Nonce_hash.t -> string list -> string list + +(** {2 Predefined nonce} *****************************************************) + +val initial_nonce_0 : nonce +val initial_nonce_hash_0 : Nonce_hash.t + +(** {2 Serializers} **********************************************************) + +val nonce_encoding : nonce Data_encoding.t +val seed_encoding : seed Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml new file mode 100644 index 000000000..6f855b652 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml @@ -0,0 +1,124 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Misc + +type error += + | Unknown of { oldest : Cycle_repr.t ; + cycle : Cycle_repr.t ; + latest : Cycle_repr.t } (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"seed.unknown_seed" + ~title:"Unknown seed" + ~description:"The requested seed is not available" + ~pp:(fun ppf (oldest, cycle, latest) -> + if Cycle_repr.(cycle < oldest) then + Format.fprintf ppf + "The seed for cycle %a has been cleared from the context \ + \ (oldest known seed is for cycle %a)" + Cycle_repr.pp cycle + Cycle_repr.pp oldest + else + Format.fprintf ppf + "The seed for cycle %a has not been computed yet \ + \ (latest known seed is for cycle %a)" + Cycle_repr.pp cycle + Cycle_repr.pp latest) + Data_encoding.(obj3 + (req "oldest" Cycle_repr.encoding) + (req "requested" Cycle_repr.encoding) + (req "latest" Cycle_repr.encoding)) + (function + | Unknown { oldest ; cycle ; latest } -> Some (oldest, cycle, latest) + | _ -> None) + (fun (oldest, cycle, latest) -> Unknown { oldest ; cycle ; latest }) + +let compute_for_cycle c ~revealed cycle = + match Cycle_repr.pred cycle with + | None -> assert false (* should not happen *) + | Some previous_cycle -> + let levels = Level_storage.levels_with_commitments_in_cycle c revealed in + let combine (c, random_seed, unrevealed) level = + Storage.Seed.Nonce.get c level >>=? function + | Revealed nonce -> + Storage.Seed.Nonce.delete c level >>=? fun c -> + return (c, Seed_repr.nonce random_seed nonce, unrevealed) + | Unrevealed u -> + Storage.Seed.Nonce.delete c level >>=? fun c -> + return (c, random_seed, u :: unrevealed) + in + Storage.Seed.For_cycle.get c previous_cycle >>=? fun prev_seed -> + let seed = Seed_repr.deterministic_seed prev_seed in + fold_left_s combine (c, seed, []) levels >>=? fun (c, seed, unrevealed) -> + Storage.Seed.For_cycle.init c cycle seed >>=? fun c -> + return (c, unrevealed) + +let for_cycle ctxt cycle = + let preserved = Constants_storage.preserved_cycles ctxt in + let current_level = Level_storage.current ctxt in + let current_cycle = current_level.cycle in + let latest = + if Cycle_repr.(current_cycle = root) then + Cycle_repr.add current_cycle (preserved + 1) + else + Cycle_repr.add current_cycle preserved in + let oldest = + match Cycle_repr.sub current_cycle preserved with + | None -> Cycle_repr.root + | Some oldest -> oldest in + fail_unless Cycle_repr.(oldest <= cycle && cycle <= latest) + (Unknown { oldest ; cycle ; latest }) >>=? fun () -> + Storage.Seed.For_cycle.get ctxt cycle + +let clear_cycle c cycle = + Storage.Seed.For_cycle.delete c cycle + +let init ctxt = + let preserved = Constants_storage.preserved_cycles ctxt in + List.fold_left2 + (fun ctxt c seed -> + ctxt >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in + Storage.Seed.For_cycle.init ctxt cycle seed) + (return ctxt) + (0 --> (preserved+1)) + (Seed_repr.initial_seeds (preserved+2)) + +let cycle_end ctxt last_cycle = + let preserved = Constants_storage.preserved_cycles ctxt in + begin + match Cycle_repr.sub last_cycle preserved with + | None -> return ctxt + | Some cleared_cycle -> + clear_cycle ctxt cleared_cycle + end >>=? fun ctxt -> + match Cycle_repr.pred last_cycle with + | None -> return (ctxt, []) + | Some revealed -> (* cycle with revelations *) + let inited_seed_cycle = Cycle_repr.add last_cycle (preserved+1) in + compute_for_cycle ctxt ~revealed inited_seed_cycle diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli new file mode 100644 index 000000000..2a1fd25a0 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Unknown of { oldest : Cycle_repr.t ; + cycle : Cycle_repr.t ; + latest : Cycle_repr.t } (* `Permanent *) + +(** Generates the first [preserved_cycles+2] seeds for which + there are no nonces. *) +val init: + Raw_context.t -> Raw_context.t tzresult Lwt.t + +val for_cycle: + Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + +(** If it is the end of the cycle, computes and stores the seed of cycle at + distance [preserved_cycle+2] in the future using the seed of the previous + cycle and the revelations of the current one. *) +val cycle_end: + Raw_context.t -> Cycle_repr.t -> + (Raw_context.t * Nonce_storage.unrevealed list) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml b/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml new file mode 100644 index 000000000..120afb9cf --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml @@ -0,0 +1,94 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type rpc_context = { + block_hash: Block_hash.t ; + block_header: Block_header.shell_header ; + context: Alpha_context.t ; +} + +let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) = + let level = block_header.level in + let timestamp = block_header.timestamp in + let fitness = block_header.fitness in + Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context -> + return { block_hash ; block_header ; context } + +let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) + +let register0_fullctxt s f = + rpc_services := + RPC_directory.register !rpc_services s + (fun ctxt q i -> + rpc_init ctxt >>=? fun ctxt -> + f ctxt q i) +let opt_register0_fullctxt s f = + rpc_services := + RPC_directory.opt_register !rpc_services s + (fun ctxt q i -> + rpc_init ctxt >>=? fun ctxt -> + f ctxt q i) +let register0 s f = + register0_fullctxt s (fun { context ; _ } -> f context) +let register0_noctxt s f = + rpc_services := + RPC_directory.register !rpc_services s + (fun _ q i -> f q i) + +let register1_fullctxt s f = + rpc_services := + RPC_directory.register !rpc_services s + (fun (ctxt, arg) q i -> + rpc_init ctxt >>=? fun ctxt -> + f ctxt arg q i) +let register1 s f = register1_fullctxt s (fun { context ; _ } x -> f context x) +let register1_noctxt s f = + rpc_services := + RPC_directory.register !rpc_services s + (fun (_, arg) q i -> f arg q i) + +let register2_fullctxt s f = + rpc_services := + RPC_directory.register !rpc_services s + (fun ((ctxt, arg1), arg2) q i -> + rpc_init ctxt >>=? fun ctxt -> + f ctxt arg1 arg2 q i) +let register2 s f = + register2_fullctxt s (fun { context ; _ } a1 a2 q i -> f context a1 a2 q i) + +let get_rpc_services () = + let p = + RPC_directory.map + (fun c -> + rpc_init c >>= function + | Error _ -> assert false + | Ok c -> Lwt.return c.context) + (Storage_description.build_directory Alpha_context.description) in + RPC_directory.register_dynamic_directory + !rpc_services + RPC_path.(open_root / "context" / "raw" / "json") + (fun _ -> Lwt.return p) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml new file mode 100644 index 000000000..ac240a4ad --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml @@ -0,0 +1,37 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let random_state_hash = "\076\064\204" (* rng(53): never used... *) + +include Blake2B.Make(Base58)(struct + let name = "random" + let title = "A random generation state" + let b58check_prefix = random_state_hash + let size = None + end) + +let () = + Base58.check_encoded_prefix b58check_encoding "rng" 53 + diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage.ml new file mode 100644 index 000000000..b2e3fd919 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage.ml @@ -0,0 +1,609 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Storage_functors + +module Int = struct + type t = int + let encoding = Data_encoding.uint16 +end + +module Int32 = struct + type t = Int32.t + let encoding = Data_encoding.int32 +end + +module Z = struct + type t = Z.t + let encoding = Data_encoding.z +end + +module Int_index = struct + type t = int + let path_length = 1 + let to_path c l = string_of_int c :: l + let of_path = function + | [] | _ :: _ :: _ -> None + | [ c ] -> int_of_string_opt c + type 'a ipath = 'a * t + let args = Storage_description.One { + rpc_arg = RPC_arg.int ; + encoding = Data_encoding.int31 ; + compare = Compare.Int.compare ; + } +end + +module Make_index(H : Storage_description.INDEX) + : INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct + include H + type 'a ipath = 'a * t + let args = Storage_description.One { + rpc_arg ; + encoding ; + compare ; + } +end + +module Last_block_priority = + Make_single_data_storage + (Raw_context) + (struct let name = ["last_block_priority"] end) + (Int) + +(** Contracts handling *) + +module Contract = struct + + module Raw_context = + Make_subcontext(Raw_context)(struct let name = ["contracts"] end) + + module Global_counter = + Make_single_data_storage + (Raw_context) + (struct let name = ["global_counter"] end) + (Z) + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Make_index(Contract_repr.Index)) + + let fold = Indexed_context.fold_keys + let list = Indexed_context.keys + + module Balance = + Indexed_context.Make_map + (struct let name = ["balance"] end) + (Tez_repr) + + module Frozen_balance_index = + Make_indexed_subcontext + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["frozen_balance"] end)) + (Make_index(Cycle_repr.Index)) + + module Frozen_deposits = + Frozen_balance_index.Make_map + (struct let name = ["deposits"] end) + (Tez_repr) + + module Frozen_fees = + Frozen_balance_index.Make_map + (struct let name = ["fees"] end) + (Tez_repr) + + module Frozen_rewards = + Frozen_balance_index.Make_map + (struct let name = ["rewards"] end) + (Tez_repr) + + module Manager = + Indexed_context.Make_map + (struct let name = ["manager"] end) + (Manager_repr) + + module Spendable = + Indexed_context.Make_set + (struct let name = ["spendable"] end) + + module Delegatable = + Indexed_context.Make_set + (struct let name = ["delegatable"] end) + + module Delegate = + Indexed_context.Make_map + (struct let name = ["delegate"] end) + (Signature.Public_key_hash) + + module Inactive_delegate = + Indexed_context.Make_set + (struct let name = ["inactive_delegate"] end) + + module Delegate_desactivation = + Indexed_context.Make_map + (struct let name = ["delegate_desactivation"] end) + (Cycle_repr) + + module Delegated = + Make_data_set_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["delegated"] end)) + (Make_index(Contract_hash)) + + module Counter = + Indexed_context.Make_map + (struct let name = ["counter"] end) + (Z) + + (* Consume gas for serilization and deserialization of expr in this + module *) + module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct + module I = Indexed_context.Make_carbonated_map + (N) + (struct + type t = Script_repr.lazy_expr + let encoding = Script_repr.lazy_expr_encoding + end) + + type context = I.context + type key = I.key + type value = I.value + + let mem = I.mem + let delete = I.delete + let remove = I.remove + + let consume_deserialize_gas ctxt value = + Lwt.return @@ + (Raw_context.check_enough_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun () -> + Script_repr.force_decode value >>? fun (_value, value_cost) -> + Raw_context.consume_gas ctxt value_cost) + + let consume_serialize_gas ctxt value = + Lwt.return @@ + (Script_repr.force_bytes value >>? fun (_value, value_cost) -> + Raw_context.consume_gas ctxt value_cost) + + let get ctxt contract = + I.get ctxt contract >>=? fun (ctxt, value) -> + consume_deserialize_gas ctxt value >>|? fun ctxt -> + (ctxt, value) + + let get_option ctxt contract = + I.get_option ctxt contract >>=? fun (ctxt, value_opt) -> + match value_opt with + | None -> return (ctxt, None) + | Some value -> + consume_deserialize_gas ctxt value >>|? fun ctxt -> + (ctxt, value_opt) + + let set ctxt contract value = + consume_serialize_gas ctxt value >>=? fun ctxt -> + I.set ctxt contract value + + let set_option ctxt contract value_opt = + match value_opt with + | None -> I.set_option ctxt contract None + | Some value -> + consume_serialize_gas ctxt value >>=? fun ctxt -> + I.set_option ctxt contract value_opt + + let init ctxt contract value = + consume_serialize_gas ctxt value >>=? fun ctxt -> + I.init ctxt contract value + + let init_set ctxt contract value = + consume_serialize_gas ctxt value >>=? fun ctxt -> + I.init_set ctxt contract value + end + + module Code = + Make_carbonated_map_expr + (struct let name = ["code"] end) + + module Storage = + Make_carbonated_map_expr + (struct let name = ["storage"] end) + + type bigmap_key = Raw_context.t * Contract_repr.t + + (* Consume gas for serilization and deserialization of expr in this + module *) + module Big_map = struct + module I = Storage_functors.Make_indexed_carbonated_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["big_map"] end)) + (Make_index(Script_expr_hash)) + (struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end) + + type context = I.context + type key = I.key + type value = I.value + + let mem = I.mem + let delete = I.delete + let remove = I.remove + let set = I.set + let set_option = I.set_option + let init = I.init + let init_set = I.init_set + + let consume_deserialize_gas ctxt value = + Lwt.return @@ + Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value) + + let get ctxt contract = + I.get ctxt contract >>=? fun (ctxt, value) -> + consume_deserialize_gas ctxt value >>|? fun ctxt -> + (ctxt, value) + + let get_option ctxt contract = + I.get_option ctxt contract >>=? fun (ctxt, value_opt) -> + match value_opt with + | None -> return (ctxt, None) + | Some value -> + consume_deserialize_gas ctxt value >>|? fun ctxt -> + (ctxt, value_opt) + end + + module Paid_storage_space = + Indexed_context.Make_map + (struct let name = ["paid_bytes"] end) + (Z) + + module Used_storage_space = + Indexed_context.Make_map + (struct let name = ["used_bytes"] end) + (Z) + + module Roll_list = + Indexed_context.Make_map + (struct let name = ["roll_list"] end) + (Roll_repr) + + module Change = + Indexed_context.Make_map + (struct let name = ["change"] end) + (Tez_repr) + +end + +module Delegates = + Make_data_set_storage + (Make_subcontext(Raw_context)(struct let name = ["delegates"] end)) + (Make_index(Signature.Public_key_hash)) + +module Active_delegates_with_rolls = + Make_data_set_storage + (Make_subcontext(Raw_context)(struct let name = ["active_delegates_with_rolls"] end)) + (Make_index(Signature.Public_key_hash)) + +module Delegates_with_frozen_balance_index = + Make_indexed_subcontext + (Make_subcontext(Raw_context) + (struct let name = ["delegates_with_frozen_balance"] end)) + (Make_index(Cycle_repr.Index)) + +module Delegates_with_frozen_balance = + Make_data_set_storage + (Delegates_with_frozen_balance_index.Raw_context) + (Make_index(Signature.Public_key_hash)) + +(** Rolls *) + +module Cycle = struct + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Raw_context)(struct let name = ["cycle"] end)) + (Make_index(Cycle_repr.Index)) + + module Last_roll = + Make_indexed_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["last_roll"] end)) + (Int_index) + (Roll_repr) + + module Roll_snapshot = + Indexed_context.Make_map + (struct let name = ["roll_snapshot"] end) + (Int) + + type unrevealed_nonce = { + nonce_hash: Nonce_hash.t ; + delegate: Signature.Public_key_hash.t ; + rewards: Tez_repr.t ; + fees: Tez_repr.t ; + } + + type nonce_status = + | Unrevealed of unrevealed_nonce + | Revealed of Seed_repr.nonce + + let nonce_status_encoding = + let open Data_encoding in + union [ + case (Tag 0) + ~title:"Unrevealed" + (tup4 + Nonce_hash.encoding + Signature.Public_key_hash.encoding + Tez_repr.encoding + Tez_repr.encoding) + (function + | Unrevealed { nonce_hash ; delegate ; rewards ; fees } -> + Some (nonce_hash, delegate, rewards, fees) + | _ -> None) + (fun (nonce_hash, delegate, rewards, fees) -> + Unrevealed { nonce_hash ; delegate ; rewards ; fees }) ; + case (Tag 1) + ~title:"Revealed" + Seed_repr.nonce_encoding + (function + | Revealed nonce -> Some nonce + | _ -> None) + (fun nonce -> Revealed nonce) + ] + + module Nonce = + Make_indexed_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["nonces"] end)) + (Make_index(Raw_level_repr.Index)) + (struct + type t = nonce_status + let encoding = nonce_status_encoding + end) + + module Seed = + Indexed_context.Make_map + (struct let name = ["random_seed"] end) + (struct + type t = Seed_repr.seed + let encoding = Seed_repr.seed_encoding + end) + +end + +module Roll = struct + + module Raw_context = + Make_subcontext(Raw_context)(struct let name = ["rolls"] end) + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Make_index(Roll_repr.Index)) + + module Next = + Make_single_data_storage + (Raw_context) + (struct let name = ["next"] end) + (Roll_repr) + + module Limbo = + Make_single_data_storage + (Raw_context) + (struct let name = ["limbo"] end) + (Roll_repr) + + module Delegate_roll_list = + Wrap_indexed_data_storage(Contract.Roll_list)(struct + type t = Signature.Public_key_hash.t + let wrap = Contract_repr.implicit_contract + let unwrap = Contract_repr.is_implicit + end) + + module Successor = + Indexed_context.Make_map + (struct let name = ["successor"] end) + (Roll_repr) + + module Delegate_change = + Wrap_indexed_data_storage(Contract.Change)(struct + type t = Signature.Public_key_hash.t + let wrap = Contract_repr.implicit_contract + let unwrap = Contract_repr.is_implicit + end) + + module Snapshoted_owner_index = struct + type t = Cycle_repr.t * int + let path_length = Cycle_repr.Index.path_length + 1 + let to_path (c, n) s = + Cycle_repr.Index.to_path c (string_of_int n :: s) + let of_path l = + match Misc.take Cycle_repr.Index.path_length l with + | None | Some (_, ([] | _ :: _ :: _ ))-> None + | Some (l1, [l2]) -> + match Cycle_repr.Index.of_path l1, int_of_string_opt l2 with + | None, _ | _, None -> None + | Some c, Some i -> Some (c, i) + + type 'a ipath = ('a * Cycle_repr.t) * int + let left_args = + Storage_description.One { + rpc_arg = Cycle_repr.rpc_arg ; + encoding = Cycle_repr.encoding ; + compare = Cycle_repr.compare + } + let right_args = + Storage_description.One { + rpc_arg = RPC_arg.int ; + encoding = Data_encoding.int31 ; + compare = Compare.Int.compare ; + } + let args = + Storage_description.(Pair (left_args, right_args)) + end + + module Owner = + Make_indexed_data_snapshotable_storage + (Make_subcontext(Raw_context)(struct let name = ["owner"] end)) + (Snapshoted_owner_index) + (Make_index(Roll_repr.Index)) + (Signature.Public_key) + + module Snapshot_for_cycle = Cycle.Roll_snapshot + module Last_for_snapshot = Cycle.Last_roll + + let clear = Indexed_context.clear + +end + +(** Votes **) + +module Vote = struct + + module Raw_context = + Make_subcontext(Raw_context)(struct let name = ["votes"] end) + + module Current_period_kind = + Make_single_data_storage + (Raw_context) + (struct let name = ["current_period_kind"] end) + (struct + type t = Voting_period_repr.kind + let encoding = Voting_period_repr.kind_encoding + end) + + module Current_quorum = + Make_single_data_storage + (Raw_context) + (struct let name = ["current_quorum"] end) + (Int32) + + module Current_proposal = + Make_single_data_storage + (Raw_context) + (struct let name = ["current_proposal"] end) + (Protocol_hash) + + module Listings_size = + Make_single_data_storage + (Raw_context) + (struct let name = ["listings_size"] end) + (Int32) + + module Listings = + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["listings"] end)) + (Make_index(Signature.Public_key_hash)) + (Int32) + + module Proposals = + Make_data_set_storage + (Make_subcontext(Raw_context)(struct let name = ["proposals"] end)) + (Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash))) + + module Proposals_count = + Make_indexed_data_storage + (Make_subcontext(Raw_context) + (struct let name = ["proposals_count"] end)) + (Make_index(Signature.Public_key_hash)) + (Int) + + module Ballots = + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["ballots"] end)) + (Make_index(Signature.Public_key_hash)) + (struct + type t = Vote_repr.ballot + let encoding = Vote_repr.ballot_encoding + end) + +end + +(** Seed *) + +module Seed = struct + + type unrevealed_nonce = Cycle.unrevealed_nonce = { + nonce_hash: Nonce_hash.t ; + delegate: Signature.Public_key_hash.t ; + rewards: Tez_repr.t ; + fees: Tez_repr.t ; + } + + type nonce_status = Cycle.nonce_status = + | Unrevealed of unrevealed_nonce + | Revealed of Seed_repr.nonce + + module Nonce = struct + open Level_repr + type context = Raw_context.t + let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level + let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level + let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level + let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v + let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v + let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v + let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v + let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level + let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level + end + module For_cycle = Cycle.Seed + +end + +(** Commitments *) + +module Commitments = + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["commitments"] end)) + (Make_index(Blinded_public_key_hash.Index)) + (Tez_repr) + +(** Ramp up security deposits... *) + +module Ramp_up = struct + + module Rewards = + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "rewards"] end)) + (Make_index(Cycle_repr.Index)) + (struct + type t = Tez_repr.t * Tez_repr.t + let encoding = Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding + end) + + module Security_deposits = + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "deposits"] end)) + (Make_index(Cycle_repr.Index)) + (struct + type t = Tez_repr.t * Tez_repr.t + let encoding = Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding + end) + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage.mli new file mode 100644 index 000000000..2e7f0b094 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage.mli @@ -0,0 +1,330 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Typed storage + + This module hides the hierarchical (key x value) database under + pre-allocated typed accessors for all persistent entities of the + tezos context. + + This interface enforces no invariant on the contents of the + database. Its goal is to centralize all accessors in order to have + a complete view over the database contents and avoid key + collisions. *) + +open Storage_sigs + +module Last_block_priority : sig + val get : Raw_context.t -> int tzresult Lwt.t + val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t + val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t +end + +module Roll : sig + + (** Storage from this submodule must only be accessed through the + module `Roll`. *) + + module Owner : Indexed_data_snapshotable_storage + with type key = Roll_repr.t + and type snapshot = (Cycle_repr.t * int) + and type value = Signature.Public_key.t + and type t := Raw_context.t + + val clear: Raw_context.t -> Raw_context.t Lwt.t + + (** The next roll to be allocated. *) + module Next : Single_data_storage + with type value = Roll_repr.t + and type t := Raw_context.t + + (** Rolls linked lists represent both account owned and free rolls. + All rolls belongs either to the limbo list or to an owned list. *) + + (** Head of the linked list of rolls in limbo *) + module Limbo : Single_data_storage + with type value = Roll_repr.t + and type t := Raw_context.t + + (** Rolls associated to contracts, a linked list per contract *) + module Delegate_roll_list : Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Roll_repr.t + and type t := Raw_context.t + + (** Use this to iter on a linked list of rolls *) + module Successor : Indexed_data_storage + with type key = Roll_repr.t + and type value = Roll_repr.t + and type t := Raw_context.t + + (** The tez of a contract that are not assigned to rolls *) + module Delegate_change : Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Tez_repr.t + and type t := Raw_context.t + + (** Index of the randomly selected roll snapshot of a given cycle. *) + module Snapshot_for_cycle : Indexed_data_storage + with type key = Cycle_repr.t + and type value = int + and type t := Raw_context.t + + (** Last roll in the snapshoted roll allocation of a given cycle. *) + module Last_for_snapshot : Indexed_data_storage + with type key = int + and type value = Roll_repr.t + and type t = Raw_context.t * Cycle_repr.t + +end + +module Contract : sig + + (** Storage from this submodule must only be accessed through the + module `Contract`. *) + + module Global_counter : sig + val get : Raw_context.t -> Z.t tzresult Lwt.t + val set : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t + val init : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t + end + + (** The domain of alive contracts *) + val fold : + Raw_context.t -> + init:'a -> f:(Contract_repr.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val list : Raw_context.t -> Contract_repr.t list Lwt.t + + (** All the tez possesed by a contract, including rolls and change *) + module Balance : Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type t := Raw_context.t + + (** Frozen balance, see 'delegate_storage.mli' for more explanation. + Always update `Delegates_with_frozen_balance` accordingly. *) + module Frozen_deposits : Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t + + module Frozen_fees : Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t + + module Frozen_rewards : Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t + + (** The manager of a contract *) + module Manager : Indexed_data_storage + with type key = Contract_repr.t + and type value = Manager_repr.t + and type t := Raw_context.t + + (** The delegate of a contract, if any. *) + module Delegate : Indexed_data_storage + with type key = Contract_repr.t + and type value = Signature.Public_key_hash.t + and type t := Raw_context.t + + module Delegated : Data_set_storage + with type elt = Contract_hash.t + and type t = Raw_context.t * Contract_repr.t + + module Inactive_delegate : Data_set_storage + with type elt = Contract_repr.t + and type t = Raw_context.t + + (** The cycle where the delegate should be desactivated. *) + module Delegate_desactivation : Indexed_data_storage + with type key = Contract_repr.t + and type value = Cycle_repr.t + and type t := Raw_context.t + + module Spendable : Data_set_storage + with type elt = Contract_repr.t + and type t := Raw_context.t + + module Delegatable : Data_set_storage + with type elt = Contract_repr.t + and type t := Raw_context.t + + module Counter : Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t + + module Code : Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + module Storage : Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + (** Current storage space in bytes. + Includes code, global storage and big map elements. *) + module Used_storage_space : Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t + + (** Maximal space available without needing to burn new fees. *) + module Paid_storage_space : Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t + + type bigmap_key = Raw_context.t * Contract_repr.t + + module Big_map : Non_iterable_indexed_carbonated_data_storage + with type key = Script_expr_hash.t + and type value = Script_repr.expr + and type t := bigmap_key + +end + +(** Set of all registered delegates. *) +module Delegates : Data_set_storage + with type t := Raw_context.t + and type elt = Signature.Public_key_hash.t + +(** Set of all active delegates with rolls. *) +module Active_delegates_with_rolls : Data_set_storage + with type t := Raw_context.t + and type elt = Signature.Public_key_hash.t + +(** Set of all the delegates with frozen rewards/bonds/fees for a given cycle. *) +module Delegates_with_frozen_balance : Data_set_storage + with type t = Raw_context.t * Cycle_repr.t + and type elt = Signature.Public_key_hash.t + +(** Votes *) + +module Vote : sig + + module Current_period_kind : Single_data_storage + with type value = Voting_period_repr.kind + and type t := Raw_context.t + + (** Expected quorum, in centile of percentage *) + module Current_quorum : Single_data_storage + with type value = int32 + and type t := Raw_context.t + + module Current_proposal : Single_data_storage + with type value = Protocol_hash.t + and type t := Raw_context.t + + (** Sum of all rolls of all delegates. *) + module Listings_size : Single_data_storage + with type value = int32 + and type t := Raw_context.t + + (** Contains all delegates with their assigned number of rolls. *) + module Listings : Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = int32 + and type t := Raw_context.t + + (** Set of protocol proposal with corresponding proposer delegate *) + module Proposals : Data_set_storage + with type elt = Protocol_hash.t * Signature.Public_key_hash.t + and type t := Raw_context.t + + (** Keeps for each delegate the number of proposed protocols *) + module Proposals_count : Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = int + and type t := Raw_context.t + + (** Contains for each delegate its ballot *) + module Ballots : Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Vote_repr.ballot + and type t := Raw_context.t + +end + +(** Seed *) + +module Seed : sig + + (** Storage from this submodule must only be accessed through the + module `Seed`. *) + + type unrevealed_nonce = { + nonce_hash: Nonce_hash.t ; + delegate: Signature.Public_key_hash.t ; + rewards: Tez_repr.t ; + fees: Tez_repr.t ; + } + + type nonce_status = + | Unrevealed of unrevealed_nonce + | Revealed of Seed_repr.nonce + + module Nonce : Non_iterable_indexed_data_storage + with type key := Level_repr.t + and type value := nonce_status + and type t := Raw_context.t + + module For_cycle : sig + val init : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed -> Raw_context.t tzresult Lwt.t + val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t + end + +end + +(** Commitments *) + +module Commitments : Indexed_data_storage + with type key = Blinded_public_key_hash.t + and type value = Tez_repr.t + and type t := Raw_context.t + +(** Ramp up security deposits... *) + +module Ramp_up : sig + + module Rewards : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t * Tez_repr.t (* baking * endorsement *) + and type t := Raw_context.t + + module Security_deposits : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t * Tez_repr.t (* baking * endorsement *) + and type t := Raw_context.t + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml new file mode 100644 index 000000000..96aef4fea --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml @@ -0,0 +1,306 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module StringMap = Map.Make(String) + +type 'key t = 'key description ref + +and 'key description = + | Empty : 'key description + | Value : { get: 'key -> 'a option tzresult Lwt.t ; + encoding: 'a Data_encoding.t } -> 'key description + | NamedDir: 'key t StringMap.t -> 'key description + | IndexedDir: { arg: 'a RPC_arg.t ; + arg_encoding: 'a Data_encoding.t ; + list: 'key -> 'a list tzresult Lwt.t ; + subdir: ('key * 'a) t }-> 'key description + +let rec register_named_subcontext : type r. r t -> string list -> r t = + fun dir names -> + match !dir, names with + | _, [] -> dir + | Value _, _ -> invalid_arg "" + | IndexedDir _, _ -> invalid_arg "" + | Empty, name :: names -> + let subdir = ref Empty in + dir := NamedDir (StringMap.singleton name subdir) ; + register_named_subcontext subdir names + | NamedDir map, name :: names -> + let subdir = + match StringMap.find_opt name map with + | Some subdir -> subdir + | None -> + let subdir = ref Empty in + dir := NamedDir (StringMap.add name subdir map) ; + subdir in + register_named_subcontext subdir names + +type (_, _, _) args = + | One : { rpc_arg: 'a RPC_arg.t ; + encoding: 'a Data_encoding.t ; + compare: 'a -> 'a -> int } -> ('key, 'a, 'key * 'a) args + | Pair : ('key, 'a, 'inter_key) args * + ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args + +let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function + | One _ -> (fun x -> x) + | Pair (l, r) -> + let unpack_l = unpack l in + let unpack_r = unpack r in + fun x -> + let c, d = unpack_r x in + let b, a = unpack_l c in + (b, (a, d)) + +let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function + | One _ -> (fun b a -> (b, a)) + | Pair (l, r) -> + let pack_l = pack l in + let pack_r = pack r in + fun b (a, d) -> + let c = pack_l b a in + pack_r c d + +let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function + | One { compare ; _ } -> compare + | Pair (l, r) -> + let compare_l = compare l in + let compare_r = compare r in + fun (a1, b1) (a2, b2) -> + match compare_l a1 a2 with + | 0 -> compare_r b1 b2 + | x -> x + +let destutter equal l = + match l with + | [] -> [] + | (i, _) :: l -> + let rec loop acc i = function + | [] -> acc + | (j, _) :: l -> + if equal i j then loop acc i l + else loop (j :: acc) j l in + loop [i] i l + +let rec register_indexed_subcontext + : type r a b. r t -> list:(r -> a list tzresult Lwt.t) -> + (r, a, b) args -> b t = + fun dir ~list path -> + match path with + | Pair (left, right) -> + let compare_left = compare left in + let equal_left x y = Compare.Int.(compare_left x y = 0) in + let list_left r = + list r >>=? fun l -> + return (destutter equal_left l) in + let list_right r = + let a, k = unpack left r in + list a >>=? fun l -> + return + (List.map snd + (List.filter (fun (x, _) -> equal_left x k) l)) in + register_indexed_subcontext + (register_indexed_subcontext dir ~list:list_left left) + ~list:list_right right + | One { rpc_arg = arg ; encoding = arg_encoding ; _ } -> + match !dir with + | Value _ -> invalid_arg "" + | NamedDir _ -> invalid_arg "" + | Empty -> + let subdir = ref Empty in + dir := IndexedDir { arg ; arg_encoding ; list ; subdir }; + subdir + | IndexedDir { arg = inner_arg ; subdir ; _ } -> + match RPC_arg.eq arg inner_arg with + | None -> invalid_arg "" + | Some RPC_arg.Eq -> subdir + +let register_value : + type a b. a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit = + fun dir ~get encoding -> + match !dir with + | Empty -> dir := Value { get ; encoding } + | _ -> invalid_arg "" + +let create () = ref Empty + +let rec pp : type a. Format.formatter -> a t -> unit = fun ppf dir -> + match !dir with + | Empty -> + Format.fprintf ppf "EMPTY" + | Value _e -> + Format.fprintf ppf "Value" + | NamedDir map -> + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list pp_item) + (StringMap.bindings map) + | IndexedDir { arg ; subdir ; _ } -> + let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in + pp_item ppf (name, subdir) + +and pp_item : type a. Format.formatter -> (string * a t) -> unit = + fun ppf (name, dir) -> + Format.fprintf ppf "@[%s@ %a@]" + name + pp dir + + +module type INDEX = sig + type t + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option + val rpc_arg: t RPC_arg.t + val encoding: t Data_encoding.t + val compare: t -> t -> int +end + +type _ handler = + Handler : + { encoding: 'a Data_encoding.t ; + get: 'key -> int -> 'a tzresult Lwt.t } -> 'key handler + +type _ opt_handler = + Opt_handler : + { encoding: 'a Data_encoding.t ; + get: 'key -> int -> 'a option tzresult Lwt.t } -> 'key opt_handler + +let rec combine_object = function + | [] -> Handler { encoding = Data_encoding.unit ; + get = fun _ _ -> return_unit } + | (name, Opt_handler handler) :: fields -> + let Handler handlers = combine_object fields in + Handler { encoding = + Data_encoding.merge_objs + Data_encoding.(obj1 (opt name (dynamic_size handler.encoding))) + handlers.encoding ; + get = fun k i -> + handler.get k i >>=? fun v1 -> + handlers.get k i >>=? fun v2 -> + return (v1, v2) } + +type query = { + depth: int ; +} + +let depth_query = + let open RPC_query in + query (fun depth -> { depth }) + |+ field "depth" RPC_arg.int 0 (fun t -> t.depth) + |> seal + +let build_directory : type key. key t -> key RPC_directory.t = + fun dir -> + let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in + let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit = + fun path (Opt_handler { encoding ; get }) -> + let service = + RPC_service.get_service + ~query: depth_query + ~output: encoding + path in + rpc_dir := + RPC_directory.register !rpc_dir service begin + fun k q () -> + get k (q.depth + 1) >>=? function + | None -> raise Not_found + | Some x -> return x + end in + let rec build_handler : type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler = + fun dir path -> + match !dir with + | Empty -> Opt_handler { encoding = Data_encoding.unit ; + get = fun _ _ -> return_none } + | Value { get ; encoding } -> + let handler = + Opt_handler { + encoding ; + get = + fun k i -> if Compare.Int.(i < 0) then return_none else get k + } in + register path handler ; + handler + | NamedDir map -> + let fields = StringMap.bindings map in + let fields = + List.map + (fun (name, dir) -> + (name, build_handler dir RPC_path.(path / name))) + fields in + let Handler handler = combine_object fields in + let handler = + Opt_handler + { encoding = handler.encoding ; + get = fun k i -> + if Compare.Int.(i < 0) then + return_none + else + handler.get k (i-1) >>=? fun v -> + return_some v } in + register path handler ; + handler + | IndexedDir { arg ; arg_encoding ; list ; subdir } -> + let Opt_handler handler = + build_handler subdir RPC_path.(path /: arg) in + let encoding = + let open Data_encoding in + union [ + case (Tag 0) + ~title:"Leaf" + (dynamic_size arg_encoding) + (function (key, None) -> Some key | _ -> None) + (fun key -> (key, None)) ; + case (Tag 1) + ~title:"Dir" + (tup2 + (dynamic_size arg_encoding) + (dynamic_size handler.encoding)) + (function (key, Some value) -> Some (key, value) | _ -> None) + (fun (key, value) -> (key, Some value)) ; + ] in + let get k i = + if Compare.Int.(i < 0) then return_none + else if Compare.Int.(i = 0) then return_some [] + else + list k >>=? fun keys -> + map_p + (fun key -> + if Compare.Int.(i = 1) then + return (key, None) + else + handler.get (k, key) (i-1) >>=? fun value -> + return (key, value)) + keys >>=? fun values -> + return_some values in + let handler = + Opt_handler { + encoding = Data_encoding.(list (dynamic_size encoding)) ; + get ; + } in + register path handler ; + handler in + ignore (build_handler dir RPC_path.open_root : key opt_handler) ; + !rpc_dir + diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli new file mode 100644 index 000000000..2f6a59fd0 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli @@ -0,0 +1,82 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Typed description of the key-value context. *) +type 'key t + +(** Trivial display of the key-value context layout. *) +val pp: Format.formatter -> 'key t -> unit + +(** Export an RPC hierarchy for querying the context. There is one service + by possible path in the context. Services for "directory" are able to + aggregate in one JSON object the whole subtree. *) +val build_directory: 'key t -> 'key RPC_directory.t + +(** Create a empty context description, + keys will be registred by side effects. *) +val create: unit -> 'key t + +(** Register a single key accessor at a given path. *) +val register_value: + 'key t -> + get:('key -> 'a option tzresult Lwt.t) -> + 'a Data_encoding.t -> unit + +(** Return a description for a prefixed fragment of the given context. + All keys registred in the subcontext will be shared by the external + context *) +val register_named_subcontext: 'key t -> string list -> 'key t + +(** Description of an index as a sequence of `RPC_arg.t`. *) +type (_, _, _) args = + | One : { rpc_arg: 'a RPC_arg.t ; + encoding: 'a Data_encoding.t ; + compare: 'a -> 'a -> int } -> ('key, 'a, 'key * 'a) args + | Pair : ('key, 'a, 'inter_key) args * + ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args + +(** Return a description for a indexed sub-context. + All keys registred in the subcontext will be shared by the external + context. One should provide a function to list all the registred + index in the context. *) +val register_indexed_subcontext: + 'key t -> + list:('key -> 'arg list tzresult Lwt.t) -> + ('key, 'arg, 'sub_key) args -> 'sub_key t + +(** Helpers for manipulating and defining indexes. *) + +val pack: ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key +val unpack: ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a + +module type INDEX = sig + type t + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option + val rpc_arg: t RPC_arg.t + val encoding: t Data_encoding.t + val compare: t -> t -> int +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml new file mode 100644 index 000000000..0fdfbc06b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml @@ -0,0 +1,878 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Storage_sigs + +module Make_encoder (V : VALUE) = struct + let of_bytes ~key b = + match Data_encoding.Binary.of_bytes V.encoding b with + | None -> Error [Raw_context.Storage_error (Corrupted_data key)] + | Some v -> Ok v + let to_bytes v = + match Data_encoding.Binary.to_bytes V.encoding v with + | Some b -> b + | None -> MBytes.create 0 +end + +let len_name = "len" +let data_name = "data" + +let encode_len_value bytes = + let length = MBytes.length bytes in + Data_encoding.(Binary.to_bytes_exn int31) length + +let decode_len_value key len = + match Data_encoding.(Binary.of_bytes int31) len with + | None -> + fail (Raw_context.Storage_error (Corrupted_data key)) + | Some len -> + return len + +let map_key f = function + | `Key k -> `Key (f k) + | `Dir k -> `Dir (f k) + +module Make_subcontext (C : Raw_context.T) (N : NAME) + : Raw_context.T with type t = C.t = struct + type t = C.t + type context = t + let name_length = List.length N.name + let to_key k = N.name @ k + let of_key k = Misc.remove_elem_from_list name_length k + let mem t k = C.mem t (to_key k) + let dir_mem t k = C.dir_mem t (to_key k) + let get t k = C.get t (to_key k) + let get_option t k = C.get_option t (to_key k) + let init t k v = C.init t (to_key k) v + let set t k v = C.set t (to_key k) v + let init_set t k v = C.init_set t (to_key k) v + let set_option t k v = C.set_option t (to_key k) v + let delete t k = C.delete t (to_key k) + let remove t k = C.remove t (to_key k) + let remove_rec t k = C.remove_rec t (to_key k) + let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_) + let fold t k ~init ~f = + C.fold t (to_key k) ~init + ~f:(fun k acc -> f (map_key of_key k) acc) + let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys + let fold_keys t k ~init ~f = + C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc) + let project = C.project + let absolute_key c k = C.absolute_key c (to_key k) + let consume_gas = C.consume_gas + let check_enough_gas = C.check_enough_gas + let description = + Storage_description.register_named_subcontext C.description N.name +end + +module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) + : Single_data_storage with type t = C.t + and type value = V.t = struct + type t = C.t + type context = t + type value = V.t + let mem t = + C.mem t N.name + include Make_encoder(V) + let get t = + C.get t N.name >>=? fun b -> + let key = C.absolute_key t N.name in + Lwt.return (of_bytes ~key b) + let get_option t = + C.get_option t N.name >>= function + | None -> return_none + | Some b -> + let key = C.absolute_key t N.name in + match of_bytes ~key b with + | Ok v -> return_some v + | Error _ as err -> Lwt.return err + let init t v = + C.init t N.name (to_bytes v) >>=? fun t -> + return (C.project t) + let set t v = + C.set t N.name (to_bytes v) >>=? fun t -> + return (C.project t) + let init_set t v = + C.init_set t N.name (to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let set_option t v = + C.set_option t N.name (Option.map ~f:to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let remove t = + C.remove t N.name >>= fun t -> + Lwt.return (C.project t) + let delete t = + C.delete t N.name >>=? fun t -> + return (C.project t) + + let () = + let open Storage_description in + register_value + ~get:get_option + (register_named_subcontext C.description N.name) + V.encoding + +end + +module type INDEX = sig + type t + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option + type 'a ipath + val args: ('a, t, 'a ipath) Storage_description.args +end + +module Pair(I1 : INDEX)(I2 : INDEX) + : INDEX with type t = I1.t * I2.t = struct + type t = I1.t * I2.t + let path_length = I1.path_length + I2.path_length + let to_path (x, y) l = I1.to_path x (I2.to_path y l) + let of_path l = + match Misc.take I1.path_length l with + | None -> None + | Some (l1, l2) -> + match I1.of_path l1, I2.of_path l2 with + | Some x, Some y -> Some (x, y) + | _ -> None + type 'a ipath = 'a I1.ipath I2.ipath + let args = Storage_description.Pair (I1.args, I2.args) +end + +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) + : Data_set_storage with type t = C.t and type elt = I.t = struct + + type t = C.t + type context = t + type elt = I.t + + let inited = MBytes.of_string "inited" + + let mem s i = + C.mem s (I.to_path i []) + let add s i = + C.init_set s (I.to_path i []) inited >>= fun t -> + Lwt.return (C.project t) + let del s i = + C.remove s (I.to_path i []) >>= fun t -> + Lwt.return (C.project t) + let set s i = function + | true -> add s i + | false -> del s i + let clear s = + C.remove_rec s [] >>= fun t -> + Lwt.return (C.project t) + + let fold s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> + match I.of_path file with + | None -> assert false + | Some p -> f p acc + end + else + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> + dig (i-1) k acc + | `Key _ -> + Lwt.return acc + end in + dig I.path_length [] init + + let elements s = + fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + (* TODO fixme 'elements...' *) + ~get:(fun c -> + let (c, k) = unpack c in + mem c k >>= function + | true -> return_some true + | false -> return_none) + (register_indexed_subcontext + ~list:(fun c -> elements c >>= return) + C.description I.args) + Data_encoding.bool + +end + +module Make_indexed_data_storage + (C : Raw_context.T) (I : INDEX) (V : VALUE) + : Indexed_data_storage with type t = C.t + and type key = I.t + and type value = V.t = struct + type t = C.t + type context = t + type key = I.t + type value = V.t + include Make_encoder(V) + let mem s i = + C.mem s (I.to_path i []) + let get s i = + C.get s (I.to_path i []) >>=? fun b -> + let key = C.absolute_key s (I.to_path i []) in + Lwt.return (of_bytes ~key b) + let get_option s i = + C.get_option s (I.to_path i []) >>= function + | None -> return_none + | Some b -> + let key = C.absolute_key s (I.to_path i []) in + match of_bytes ~key b with + | Ok v -> return_some v + | Error _ as err -> Lwt.return err + let set s i v = + C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> + return (C.project t) + let init s i v = + C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> + return (C.project t) + let init_set s i v = + C.init_set s (I.to_path i []) (to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let set_option s i v = + C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let remove s i = + C.remove s (I.to_path i []) >>= fun t -> + Lwt.return (C.project t) + let delete s i = + C.delete s (I.to_path i []) >>=? fun t -> + return (C.project t) + let clear s = + C.remove_rec s [] >>= fun t -> + Lwt.return (C.project t) + + let fold_keys s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> + match I.of_path file with + | None -> assert false + | Some path -> f path acc + end + else + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc + end in + dig I.path_length [] init + + let fold s ~init ~f = + let f path acc = + get s path >>= function + | Error _ -> + (* FIXME: silently ignore unparsable data *) + Lwt.return acc + | Ok v -> + f path v acc in + fold_keys s ~init ~f + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) + let keys s = + fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k) + (register_indexed_subcontext + ~list:(fun c -> keys c >>= return) + C.description I.args) + V.encoding + +end + +module Make_indexed_carbonated_data_storage + (C : Raw_context.T) (I : INDEX) (V : VALUE) + : Non_iterable_indexed_carbonated_data_storage with type t = C.t + and type key = I.t + and type value = V.t = struct + type t = C.t + type context = t + type key = I.t + type value = V.t + include Make_encoder(V) + let name i = + I.to_path i [data_name] + let len_name i = + I.to_path i [len_name] + let consume_mem_gas c = + Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) + let existing_size c i = + C.get_option c (len_name i) >>= function + | None -> return 0 + | Some len -> decode_len_value (len_name i) len + let consume_read_gas get c i = + get c (len_name i) >>=? fun len -> + decode_len_value (len_name i) len >>=? fun len -> + Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) + let consume_serialize_write_gas set c i v = + let bytes = to_bytes v in + let len = MBytes.length bytes in + Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) >>=? fun c -> + Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c -> + set c (len_name i) (encode_len_value bytes) >>=? fun c -> + return (c, bytes) + let consume_remove_gas del c i = + Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c -> + del c (len_name i) + let mem s i = + consume_mem_gas s >>=? fun s -> + C.mem s (name i) >>= fun exists -> + return (C.project s, exists) + let get s i = + consume_read_gas C.get s i >>=? fun s -> + C.get s (name i) >>=? fun b -> + let key = C.absolute_key s (name i) in + Lwt.return (of_bytes ~key b) >>=? fun v -> + return (C.project s, v) + let get_option s i = + consume_mem_gas s >>=? fun s -> + C.mem s (name i) >>= fun exists -> + if exists then + get s i >>=? fun (s, v) -> + return (s, Some v) + else + return (C.project s, None) + let set s i v = + existing_size s i >>=? fun prev_size -> + consume_serialize_write_gas C.set s i v >>=? fun (s, bytes) -> + C.set s (name i) bytes >>=? fun t -> + let size_diff = MBytes.length bytes - prev_size in + return (C.project t, size_diff) + let init s i v = + consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) -> + C.init s (name i) bytes >>=? fun t -> + let size = MBytes.length bytes in + return (C.project t, size) + let init_set s i v = + let init_set s i v = C.init_set s i v >>= return in + existing_size s i >>=? fun prev_size -> + consume_serialize_write_gas init_set s i v >>=? fun (s, bytes) -> + init_set s (name i) bytes >>=? fun t -> + let size_diff = MBytes.length bytes - prev_size in + return (C.project t, size_diff) + let remove s i = + let remove s i = C.remove s i >>= return in + existing_size s i >>=? fun prev_size -> + consume_remove_gas remove s i >>=? fun s -> + remove s (name i) >>=? fun t -> + return (C.project t, prev_size) + let delete s i = + existing_size s i >>=? fun prev_size -> + consume_remove_gas C.delete s i >>=? fun s -> + C.delete s (name i) >>=? fun t -> + return (C.project t, prev_size) + let set_option s i v = + match v with + | None -> remove s i + | Some v -> init_set s i v + + let fold_keys_unaccounted s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> + match I.of_path file with + | None -> assert false + | Some path -> f path acc + end + else + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc + end in + dig I.path_length [data_name] init + + let keys_unaccounted s = + fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + (* TODO export consumed gas ?? *) + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k >>=? fun (_, v) -> + return v) + (register_indexed_subcontext + ~list:(fun c -> keys_unaccounted c >>= return) + C.description I.args) + V.encoding + +end + + +module Make_indexed_data_snapshotable_storage (C : Raw_context.T) + (Snapshot_index : INDEX) (I : INDEX) (V : VALUE) + : Indexed_data_snapshotable_storage with type t = C.t + and type snapshot = Snapshot_index.t + and type key = I.t + and type value = V.t = struct + type snapshot = Snapshot_index.t + + let data_name = ["current"] + let snapshot_name = ["snapshot"] + + module C_data = Make_subcontext(C)(struct let name = data_name end) + module C_snapshot = Make_subcontext(C)(struct let name = snapshot_name end) + + include Make_indexed_data_storage(C_data)(I) (V) + module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V) + + let snapshot_path id = snapshot_name @ Snapshot_index.to_path id [] + + let snapshot_exists s id = + C.dir_mem s (snapshot_path id) + + let snapshot s id = + C.copy s ~from:data_name ~to_:(snapshot_path id) >>=? fun t -> + return (C.project t) + + let delete_snapshot s id = + C.remove_rec s (snapshot_path id) >>= fun t -> + Lwt.return (C.project t) + +end + + +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) + : Indexed_raw_context with type t = C.t + and type key = I.t + and type 'a ipath = 'a I.ipath = struct + + type t = C.t + type context = t + type key = I.t + type 'a ipath = 'a I.ipath + + let clear t = + C.remove_rec t [] >>= fun t -> + Lwt.return (C.project t) + + let fold_keys t ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 0) then + match I.of_path path with + | None -> assert false + | Some path -> f path acc + else + C.fold t path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc + end in + dig I.path_length [] init + + let keys t = + fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) + + let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + + let description = + Storage_description.register_indexed_subcontext + ~list:(fun c -> keys c >>= return) + C.description + I.args + + let unpack = Storage_description.unpack I.args + let pack = Storage_description.pack I.args + + module Raw_context = struct + type t = C.t I.ipath + type context = t + let to_key i k = I.to_path i k + let of_key k = Misc.remove_elem_from_list I.path_length k + let mem c k = let (t, i) = unpack c in C.mem t (to_key i k) + let dir_mem c k = let (t, i) = unpack c in C.dir_mem t (to_key i k) + let get c k = let (t, i) = unpack c in C.get t (to_key i k) + let get_option c k = let (t, i) = unpack c in C.get_option t (to_key i k) + let init c k v = + let (t, i) = unpack c in + C.init t (to_key i k) v >>=? fun t -> return (pack t i) + let set c k v = + let (t, i) = unpack c in + C.set t (to_key i k) v >>=? fun t -> return (pack t i) + let init_set c k v = + let (t, i) = unpack c in + C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i) + let set_option c k v = + let (t, i) = unpack c in + C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i) + let delete c k = + let (t, i) = unpack c in + C.delete t (to_key i k) >>=? fun t -> return (pack t i) + let remove c k = + let (t, i) = unpack c in + C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i) + let remove_rec c k = + let (t, i) = unpack c in + C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i) + let copy c ~from ~to_ = + let (t, i) = unpack c in + C.copy t ~from:(to_key i from) ~to_:(to_key i to_) >>=? fun t -> + return (pack t i) + let fold c k ~init ~f = + let (t, i) = unpack c in + C.fold t (to_key i k) ~init + ~f:(fun k acc -> f (map_key of_key k) acc) + let keys c k = + let (t, i) = unpack c in + C.keys t (to_key i k) >|= fun keys -> List.map of_key keys + let fold_keys c k ~init ~f = + let (t, i) = unpack c in + C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc) + let project c = + let (t, _) = unpack c in + C.project t + let absolute_key c k = + let (t, i) = unpack c in + C.absolute_key t (to_key i k) + let consume_gas c g = + let (t, i) = unpack c in + C.consume_gas t g >>? fun t -> ok (pack t i) + let check_enough_gas c g = + let (t, _i) = unpack c in + C.check_enough_gas t g + let description = description + end + + let resolve t prefix = + let rec loop i prefix = function + | [] when Compare.Int.(i = I.path_length) -> begin + match I.of_path prefix with + | None -> assert false + | Some path -> Lwt.return [path] + end + | [] -> + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes + >|= List.flatten + | [d] when Compare.Int.(i = I.path_length - 1) -> + if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> + match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with + | None -> Lwt.return_nil + | Some _ -> loop (i+1) prefix []) + prefixes + >|= List.flatten + | "" :: ds -> + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes + >|= List.flatten + | d :: ds -> + if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; + C.dir_mem t (prefix @ [d]) >>= function + | true -> loop (i+1) (prefix @ [d]) ds + | false -> Lwt.return_nil in + loop 0 [] prefix + + module Make_set (N : NAME) = struct + type t = C.t + type context = t + type elt = I.t + let inited = MBytes.of_string "inited" + let mem s i = Raw_context.mem (pack s i) N.name + let add s i = + Raw_context.init_set (pack s i) N.name inited >>= fun c -> + let (s, _) = unpack c in + Lwt.return (C.project s) + let del s i = + Raw_context.remove (pack s i) N.name >>= fun c -> + let (s, _) = unpack c in + Lwt.return (C.project s) + let set s i = function + | true -> add s i + | false -> del s i + let clear s = + fold_keys s + ~init:s + ~f:begin fun i s -> + Raw_context.remove (pack s i) N.name >>= fun c -> + let (s, _) = unpack c in + Lwt.return s + end >>= fun t -> + Lwt.return (C.project t) + let fold s ~init ~f = + fold_keys s ~init + ~f:(fun i acc -> + mem s i >>= function + | true -> f i acc + | false -> Lwt.return acc) + let elements s = + fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + mem c k >>= function + | true -> return_some true + | false -> return_none) + (register_named_subcontext Raw_context.description N.name) + Data_encoding.bool + + end + + module Make_map (N : NAME) (V : VALUE) = struct + type t = C.t + type context = t + type key = I.t + type value = V.t + include Make_encoder(V) + let mem s i = + Raw_context.mem (pack s i) N.name + let get s i = + Raw_context.get (pack s i) N.name >>=? fun b -> + let key = Raw_context.absolute_key (pack s i) N.name in + Lwt.return (of_bytes ~key b) + let get_option s i = + Raw_context.get_option (pack s i) N.name >>= function + | None -> return_none + | Some b -> + let key = Raw_context.absolute_key (pack s i) N.name in + match of_bytes ~key b with + | Ok v -> return_some v + | Error _ as err -> Lwt.return err + let set s i v = + Raw_context.set (pack s i) N.name (to_bytes v) >>=? fun c -> + let (s, _) = unpack c in + return (C.project s) + let init s i v = + Raw_context.init (pack s i) N.name (to_bytes v) >>=? fun c -> + let (s, _) = unpack c in + return (C.project s) + let init_set s i v = + Raw_context.init_set (pack s i) N.name (to_bytes v) >>= fun c -> + let (s, _) = unpack c in + Lwt.return (C.project s) + let set_option s i v = + Raw_context.set_option (pack s i) + N.name (Option.map ~f:to_bytes v) >>= fun c -> + let (s, _) = unpack c in + Lwt.return (C.project s) + let remove s i = + Raw_context.remove (pack s i) N.name >>= fun c -> + let (s, _) = unpack c in + Lwt.return (C.project s) + let delete s i = + Raw_context.delete (pack s i) N.name >>=? fun c -> + let (s, _) = unpack c in + return (C.project s) + let clear s = + fold_keys s ~init:s + ~f:begin fun i s -> + Raw_context.remove (pack s i) N.name >>= fun c -> + let (s, _) = unpack c in + Lwt.return s + end >>= fun t -> + Lwt.return (C.project t) + let fold s ~init ~f = + fold_keys s ~init + ~f:(fun i acc -> + get s i >>= function + | Error _ -> Lwt.return acc + | Ok v -> f i v acc) + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) + let fold_keys s ~init ~f = + fold_keys s ~init + ~f:(fun i acc -> + mem s i >>= function + | false -> Lwt.return acc + | true -> f i acc) + let keys s = + fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k) + (register_named_subcontext Raw_context.description N.name) + V.encoding + + end + + module Make_carbonated_map (N : NAME) (V : VALUE) = struct + type t = C.t + type context = t + type key = I.t + type value = V.t + include Make_encoder(V) + let len_name = len_name :: N.name + let data_name = data_name :: N.name + let consume_mem_gas c = + Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) + let existing_size c = + Raw_context.get_option c len_name >>= function + | None -> return 0 + | Some len -> decode_len_value len_name len + let consume_read_gas get c = + get c (len_name) >>=? fun len -> + decode_len_value len_name len >>=? fun len -> + Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) + let consume_write_gas set c v = + let bytes = to_bytes v in + let len = MBytes.length bytes in + Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c -> + set c len_name (encode_len_value bytes) >>=? fun c -> + return (c, bytes) + let consume_remove_gas del c = + Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c -> + del c len_name + let mem s i = + consume_mem_gas (pack s i) >>=? fun c -> + Raw_context.mem c data_name >>= fun res -> + return (Raw_context.project c, res) + let get s i = + consume_read_gas Raw_context.get (pack s i) >>=? fun c -> + Raw_context.get c data_name >>=? fun b -> + let key = Raw_context.absolute_key c data_name in + Lwt.return (of_bytes ~key b) >>=? fun v -> + return (Raw_context.project c, v) + let get_option s i = + consume_mem_gas (pack s i) >>=? fun c -> + let (s, _) = unpack c in + Raw_context.mem (pack s i) data_name >>= fun exists -> + if exists then + get s i >>=? fun (s, v) -> + return (s, Some v) + else + return (C.project s, None) + let set s i v = + existing_size (pack s i) >>=? fun prev_size -> + consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) -> + Raw_context.set c data_name bytes >>=? fun c -> + let size_diff = MBytes.length bytes - prev_size in + return (Raw_context.project c, size_diff) + let init s i v = + consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) -> + Raw_context.init c data_name bytes >>=? fun c -> + let size = MBytes.length bytes in + return (Raw_context.project c, size) + let init_set s i v = + let init_set c k v = Raw_context.init_set c k v >>= return in + existing_size (pack s i) >>=? fun prev_size -> + consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) -> + init_set c data_name bytes >>=? fun c -> + let size_diff = MBytes.length bytes - prev_size in + return (Raw_context.project c, size_diff) + let remove s i = + let remove c k = Raw_context.remove c k >>= return in + existing_size (pack s i) >>=? fun prev_size -> + consume_remove_gas remove (pack s i) >>=? fun c -> + remove c data_name >>=? fun c -> + return (Raw_context.project c, prev_size) + let delete s i = + existing_size (pack s i) >>=? fun prev_size -> + consume_remove_gas Raw_context.delete (pack s i) >>=? fun c -> + Raw_context.delete c data_name >>=? fun c -> + return (Raw_context.project c, prev_size) + let set_option s i v = + match v with + | None -> remove s i + | Some v -> init_set s i v + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k >>=? fun (_, v) -> + return v) + (register_named_subcontext Raw_context.description N.name) + V.encoding + + end + +end + +module Wrap_indexed_data_storage + (C : Indexed_data_storage) + (K : sig + type t + val wrap: t -> C.key + val unwrap: C.key -> t option + end) = struct + type t = C.t + type context = C.t + type key = K.t + type value = C.value + let mem ctxt k = C.mem ctxt (K.wrap k) + let get ctxt k = C.get ctxt (K.wrap k) + let get_option ctxt k = C.get_option ctxt (K.wrap k) + let set ctxt k v = C.set ctxt (K.wrap k) v + let init ctxt k v = C.init ctxt (K.wrap k) v + let init_set ctxt k v = C.init_set ctxt (K.wrap k) v + let set_option ctxt k v = C.set_option ctxt (K.wrap k) v + let delete ctxt k = C.delete ctxt (K.wrap k) + let remove ctxt k = C.remove ctxt (K.wrap k) + let clear ctxt = C.clear ctxt + let fold ctxt ~init ~f = + C.fold ctxt ~init ~f:(fun k v acc -> + match K.unwrap k with + | None -> Lwt.return acc + | Some k -> f k v acc) + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) + let fold_keys s ~init ~f = + C.fold_keys s ~init + ~f:(fun k acc -> + match K.unwrap k with + | None -> Lwt.return acc + | Some k -> f k acc) + let keys s = + fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli new file mode 100644 index 000000000..83452908c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli @@ -0,0 +1,85 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Typed storage builders. *) + +open Storage_sigs + +module Make_subcontext (C : Raw_context.T) (N : NAME) + : Raw_context.T with type t = C.t + +module Make_single_data_storage + (C : Raw_context.T) (N : NAME) (V : VALUE) + : Single_data_storage with type t = C.t + and type value = V.t + +module type INDEX = sig + type t + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option + type 'a ipath + val args: ('a, t, 'a ipath) Storage_description.args +end + +module Pair(I1 : INDEX)(I2 : INDEX) : INDEX with type t = I1.t * I2.t + +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) + : Data_set_storage with type t = C.t and type elt = I.t + +module Make_indexed_data_storage + (C : Raw_context.T) (I : INDEX) (V : VALUE) + : Indexed_data_storage with type t = C.t + and type key = I.t + and type value = V.t + +module Make_indexed_carbonated_data_storage + (C : Raw_context.T) (I : INDEX) (V : VALUE) + : Non_iterable_indexed_carbonated_data_storage with type t = C.t + and type key = I.t + and type value = V.t + +module Make_indexed_data_snapshotable_storage (C : Raw_context.T) + (Snapshot : INDEX) (I : INDEX) (V : VALUE) + : Indexed_data_snapshotable_storage with type t = C.t + and type snapshot = Snapshot.t + and type key = I.t + and type value = V.t + +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) + : Indexed_raw_context with type t = C.t + and type key = I.t + and type 'a ipath = 'a I.ipath + +module Wrap_indexed_data_storage + (C : Indexed_data_storage) + (K : sig + type t + val wrap: t -> C.key + val unwrap: C.key -> t option + end) + : Indexed_data_storage with type t = C.t + and type key = K.t + and type value = C.value diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml new file mode 100644 index 000000000..2831aaf71 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml @@ -0,0 +1,392 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 Entity Accessor Signatures} ****************************************) + +(** The generic signature of a single data accessor (a single value + bound to a specific key in the hierarchical (key x value) + database). *) +module type Single_data_storage = sig + + type t + type context = t + + (** The type of the value *) + type value + + (** Tells if the data is already defined *) + val mem: context -> bool Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails *) + val get: context -> value tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails *) + val get_option: context -> value option tzresult Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Existing_key} if the bucket exists *) + val init: context -> value -> Raw_context.t tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_Error + Missing_key} if the value does not exists *) + val set: context -> value -> Raw_context.t tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists *) + val init_set: context -> value -> Raw_context.t Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option: context -> value option -> Raw_context.t Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists *) + val delete: context -> Raw_context.t tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if + the bucket does not exists *) + val remove: context -> Raw_context.t Lwt.t + +end + +(** Variant of {!Single_data_storage} with gas accounting. *) +module type Single_carbonated_data_storage = sig + + type t + type context = t + + (** The type of the value *) + type value + + (** Tells if the data is already defined. + Consumes [Gas_repr.read_bytes_cost Z.zero]. *) + val mem: context -> (Raw_context.t * bool) tzresult Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails. + Consumes [Gas_repr.read_bytes_cost ]. *) + val get: context -> (Raw_context.t * value) tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails. + Consumes [Gas_repr.read_bytes_cost ] if present + or [Gas_repr.read_bytes_cost Z.zero]. *) + val get_option: context -> (Raw_context.t * value option) tzresult Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Missing_key} if the bucket exists. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the size. *) + val init: context -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_Error + Existing_key} if the value does not exists. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old to the new size. *) + val set: context -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old (maybe 0) to the new size. *) + val init_set: context -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. + Consumes the same gas cost as either {!remove} or {!init_set}. + Returns the difference from the old (maybe 0) to the new size. *) + val set_option: context -> value option -> (Raw_context.t * int) tzresult Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size. *) + val delete: context -> (Raw_context.t * int) tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if + the bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size. *) + val remove: context -> (Raw_context.t * int) tzresult Lwt.t + +end + +(** Restricted version of {!Indexed_data_storage} w/o iterators. *) +module type Non_iterable_indexed_data_storage = sig + + type t + type context = t + + (** An abstract type for keys *) + type key + + (** The type of values *) + type value + + (** Tells if a given key is already bound to a storage bucket *) + val mem: context -> key -> bool Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns {!Storage_error Missing_key} if the key is not set ; + returns {!Storage_error Corrupted_data} if the deserialisation + fails. *) + val get: context -> key -> value tzresult Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set ; returns {!Storage_error + Corrupted_data} if the deserialisation fails. *) + val get_option: context -> key -> value option tzresult Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set: context -> key -> value -> Raw_context.t tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init: context -> key -> value -> Raw_context.t tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it + with a value ; just updates it if the bucket exists. *) + val init_set: context -> key -> value -> Raw_context.t Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option: context -> key -> value option -> Raw_context.t Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error Missing_key} if the bucket does not exists. *) + val delete: context -> key -> Raw_context.t tzresult Lwt.t + + (** Removes a storage bucket and its contents ; does nothing if the + bucket does not exists. *) + val remove: context -> key -> Raw_context.t Lwt.t + +end + +(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *) +module type Non_iterable_indexed_carbonated_data_storage = sig + + type t + type context = t + + (** An abstract type for keys *) + type key + + (** The type of values *) + type value + + (** Tells if a given key is already bound to a storage bucket. + Consumes [Gas_repr.read_bytes_cost Z.zero]. *) + val mem: context -> key -> (Raw_context.t * bool) tzresult Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns {!Storage_error Missing_key} if the key is not set ; + returns {!Storage_error Corrupted_data} if the deserialisation + fails. + Consumes [Gas_repr.read_bytes_cost ]. *) + val get: context -> key -> (Raw_context.t * value) tzresult Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set ; returns {!Storage_error + Corrupted_data} if the deserialisation fails. + Consumes [Gas_repr.read_bytes_cost ] if present + or [Gas_repr.read_bytes_cost Z.zero]. *) + val get_option: context -> key -> (Raw_context.t * value option) tzresult Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. + Consumes serialization cost. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old to the new size. *) + val set: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. + Consumes serialization cost. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the size. *) + val init: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it + with a value ; just updates it if the bucket exists. + Consumes serialization cost. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old (maybe 0) to the new size. *) + val init_set: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. + Consumes serialization cost. + Consumes the same gas cost as either {!remove} or {!init_set}. + Returns the difference from the old (maybe 0) to the new size. *) + val set_option: context -> key -> value option -> (Raw_context.t * int) tzresult Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error Missing_key} if the bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size. *) + val delete: context -> key -> (Raw_context.t * int) tzresult Lwt.t + + (** Removes a storage bucket and its contents ; does nothing if the + bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size. *) + val remove: context -> key -> (Raw_context.t * int) tzresult Lwt.t + +end + +(** The generic signature of indexed data accessors (a set of values + of the same type indexed by keys of the same form in the + hierarchical (key x value) database). *) +module type Indexed_data_storage = sig + + include Non_iterable_indexed_data_storage + + (** Empties all the keys and associated data. *) + val clear: context -> Raw_context.t Lwt.t + + (** Lists all the keys. *) + val keys: context -> key list Lwt.t + + (** Lists all the keys and associated data. *) + val bindings: context -> (key * value) list Lwt.t + + (** Iterates over all the keys and associated data. *) + val fold: + context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Iterate over all the keys. *) + val fold_keys: + context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + +end + +module type Indexed_data_snapshotable_storage = sig + type snapshot + type key + + include Indexed_data_storage with type key := key + + module Snapshot : Indexed_data_storage + with type key = (snapshot * key) + and type value = value + and type t = t + + val snapshot_exists : context -> snapshot -> bool Lwt.t + val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t + val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t + +end + +(** The generic signature of a data set accessor (a set of values + bound to a specific key prefix in the hierarchical (key x value) + database). *) +module type Data_set_storage = sig + + type t + type context = t + + (** The type of elements. *) + type elt + + (** Tells if a elt is a member of the set *) + val mem: context -> elt -> bool Lwt.t + + (** Adds a elt is a member of the set *) + val add: context -> elt -> Raw_context.t Lwt.t + + (** Removes a elt of the set ; does nothing if not a member *) + val del: context -> elt -> Raw_context.t Lwt.t + + (** Adds/Removes a elt of the set *) + val set: context -> elt -> bool -> Raw_context.t Lwt.t + + (** Returns the elements of the set, deserialized in a list in no + particular order. *) + val elements: context -> elt list Lwt.t + + (** Iterates over the elements of the set. *) + val fold: context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Removes all elements in the set *) + val clear: context -> Raw_context.t Lwt.t + +end + +module type NAME = sig + val name: Raw_context.key +end + +module type VALUE = sig + type t + val encoding: t Data_encoding.t +end + +module type Indexed_raw_context = sig + + type t + type context = t + type key + type 'a ipath + + val clear: context -> Raw_context.t Lwt.t + + val fold_keys: + context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val keys: context -> key list Lwt.t + + val resolve: context -> string list -> key list Lwt.t + + module Make_set (N : NAME) + : Data_set_storage with type t = t + and type elt = key + + module Make_map (N : NAME) (V : VALUE) + : Indexed_data_storage with type t = t + and type key = key + and type value = V.t + + module Make_carbonated_map (N : NAME) (V : VALUE) + : Non_iterable_indexed_carbonated_data_storage with type t = t + and type key = key + and type value = V.t + + module Raw_context : Raw_context.T with type t = t ipath + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml new file mode 100644 index 000000000..aa8da3282 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Qty_repr.Make (struct let id = "tez" end) + +type t = qty +type tez = qty + +let encoding = + Data_encoding.def "mutez" @@ + encoding diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli new file mode 100644 index 000000000..80eb6dbed --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t +type tez = t + +include (Qty_repr.S with type qty := t) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam new file mode 100644 index 000000000..15bc2a46b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "ocamlfind" { build } + "dune" { build & >= "1.7" } + "tezos-base" + "tezos-protocol-alpha" + "tezos-protocol-compiler" + "tezos-protocol-updater" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "alpha" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition, embedded in `tezos-node`" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam new file mode 100644 index 000000000..014be54fc --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam @@ -0,0 +1,32 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "ocamlfind" { build } + "dune" { build & >= "1.7" } + "tezos-base" + "tezos-protocol-compiler" + "alcotest-lwt" { with-test } + "tezos-alpha-test-helpers" { with-test } + "tezos-stdlib-unix" { with-test } + "tezos-protocol-environment" { with-test } + "tezos-protocol-alpha-parameters" { with-test } + "tezos-shell-services" { with-test } + "bip39" { with-test } +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "alpha" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: tests for economic-protocol definition" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam new file mode 100644 index 000000000..af0f2d8ef --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +version: "ligo" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "ocamlfind" { build } + "dune" { build & >= "1.7" } + "tezos-base" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "alpha" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml new file mode 100644 index 000000000..cf81a0019 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Time +type time = t + +type error += Timestamp_add (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"timestamp_add" + ~title:"Timestamp add" + ~description:"Overflow when adding timestamps." + ~pp:(fun ppf () -> + Format.fprintf ppf "Overflow when adding timestamps.") + Data_encoding.empty + (function Timestamp_add -> Some () | _ -> None) + (fun () -> Timestamp_add) + +let of_seconds s = + try Some (of_seconds (Int64.of_string s)) + with _ -> None +let to_seconds = to_seconds +let to_seconds_string s = Int64.to_string (to_seconds s) + +let pp = pp_hum + +let (+?) x y = + (* TODO check overflow *) + try ok (add x (Period_repr.to_seconds y)) + with _exn -> Error [ Timestamp_add ] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli new file mode 100644 index 000000000..4269fe68c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli @@ -0,0 +1,34 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include module type of (struct include Time end) +type time = t + +val pp: Format.formatter -> t -> unit +val of_seconds: string -> time option +val to_seconds_string: time -> string + +val (+?) : time -> Period_repr.t -> time tzresult + diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml new file mode 100644 index 000000000..64e01f7ca --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml @@ -0,0 +1,50 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type proposal = Protocol_hash.t + +type ballot = Yay | Nay | Pass + +let ballot_encoding = + let of_int8 = function + | 0 -> Yay + | 1 -> Nay + | 2 -> Pass + | _ -> invalid_arg "ballot_of_int8" + in + let to_int8 = function + | Yay -> 0 + | Nay -> 1 + | Pass -> 2 + in + let open Data_encoding in + (* union *) + splitted + ~binary: (conv to_int8 of_int8 int8) + ~json: (string_enum [ + "yay", Yay ; + "nay", Nay ; + "pass", Pass ; + ]) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli new file mode 100644 index 000000000..ad83b08f0 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli @@ -0,0 +1,32 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** a protocol change proposal *) +type proposal = Protocol_hash.t + +(** votes can be for, against or neutral. + Neutral serves to count towards a quorum *) +type ballot = Yay | Nay | Pass +val ballot_encoding: ballot Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml new file mode 100644 index 000000000..3a2a7b452 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml @@ -0,0 +1,138 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let recorded_proposal_count_for_delegate ctxt proposer = + Storage.Vote.Proposals_count.get_option ctxt proposer >>=? function + | None -> return 0 + | Some count -> return count + +let record_proposal ctxt proposal proposer = + recorded_proposal_count_for_delegate ctxt proposer >>=? fun count -> + Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1) >>= fun ctxt -> + Storage.Vote.Proposals.add ctxt (proposal, proposer) >>= fun ctxt -> + return ctxt + +let get_proposals ctxt = + Storage.Vote.Proposals.fold ctxt + ~init:(ok Protocol_hash.Map.empty) + ~f:(fun (proposal, delegate) acc -> + (* Assuming the same listings is used at votings *) + Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> + Lwt.return begin acc >>? fun acc -> + let previous = + match Protocol_hash.Map.find_opt proposal acc with + | None -> 0l + | Some x -> x + in + ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) + end) + +let clear_proposals ctxt = + Storage.Vote.Proposals_count.clear ctxt >>= fun ctxt -> + Storage.Vote.Proposals.clear ctxt + +type ballots = { + yay: int32 ; + nay: int32 ; + pass: int32 ; +} + +let ballots_encoding = + let open Data_encoding in + conv + (fun { yay ; nay ; pass } -> ( yay , nay , pass )) + (fun ( yay , nay , pass ) -> { yay ; nay ; pass }) + @@ obj3 + (req "yay" int32) + (req "nay" int32) + (req "pass" int32) + +let has_recorded_ballot = Storage.Vote.Ballots.mem +let record_ballot = Storage.Vote.Ballots.init + +let get_ballots ctxt = + Storage.Vote.Ballots.fold ctxt + ~f:(fun delegate ballot (ballots: ballots tzresult) -> + (* Assuming the same listings is used at votings *) + Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> + let count = Int32.add weight in + Lwt.return begin + ballots >>? fun ballots -> + match ballot with + | Yay -> ok { ballots with yay = count ballots.yay } + | Nay -> ok { ballots with nay = count ballots.nay } + | Pass -> ok { ballots with pass = count ballots.pass } + end) + ~init:(ok { yay = 0l ; nay = 0l; pass = 0l }) + +let get_ballot_list = Storage.Vote.Ballots.bindings + +let clear_ballots = Storage.Vote.Ballots.clear + +let listings_encoding = + Data_encoding.(list (obj2 + (req "pkh" Signature.Public_key_hash.encoding) + (req "rolls" int32))) + +let freeze_listings ctxt = + Roll_storage.fold ctxt (ctxt, 0l) + ~f:(fun _roll delegate (ctxt, total) -> + (* TODO use snapshots *) + let delegate = Signature.Public_key.hash delegate in + begin + Storage.Vote.Listings.get_option ctxt delegate >>=? function + | None -> return 0l + | Some count -> return count + end >>=? fun count -> + Storage.Vote.Listings.init_set + ctxt delegate (Int32.succ count) >>= fun ctxt -> + return (ctxt, Int32.succ total)) >>=? fun (ctxt, total) -> + Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> + return ctxt + +let listing_size = Storage.Vote.Listings_size.get +let in_listings = Storage.Vote.Listings.mem +let get_listings = Storage.Vote.Listings.bindings + +let clear_listings ctxt = + Storage.Vote.Listings.clear ctxt >>= fun ctxt -> + Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> + return ctxt + +let get_current_period_kind = Storage.Vote.Current_period_kind.get +let set_current_period_kind = Storage.Vote.Current_period_kind.set + +let get_current_quorum = Storage.Vote.Current_quorum.get +let set_current_quorum = Storage.Vote.Current_quorum.set + +let get_current_proposal = Storage.Vote.Current_proposal.get +let init_current_proposal = Storage.Vote.Current_proposal.init +let clear_current_proposal = Storage.Vote.Current_proposal.delete + +let init ctxt = + (* quorum is in centile of a percentage *) + Storage.Vote.Current_quorum.init ctxt 80_00l >>=? fun ctxt -> + Storage.Vote.Current_period_kind.init ctxt Proposal >>=? fun ctxt -> + return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli new file mode 100644 index 000000000..3853f5e8f --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli @@ -0,0 +1,96 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Manages all the voting related storage in Storage.Vote. *) + +(** Records a protocol proposal with the delegate that proposed it. *) +val record_proposal: + Raw_context.t -> Protocol_hash.t -> Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t + +val recorded_proposal_count_for_delegate: + Raw_context.t -> Signature.Public_key_hash.t -> + int tzresult Lwt.t + +(** Computes for each proposal how many delegates proposed it. *) +val get_proposals: + Raw_context.t -> int32 Protocol_hash.Map.t tzresult Lwt.t + +val clear_proposals: Raw_context.t -> Raw_context.t Lwt.t + +(** Counts of the votes *) +type ballots = { + yay: int32 ; + nay: int32 ; + pass: int32 ; +} + +val ballots_encoding : ballots Data_encoding.t + +val has_recorded_ballot : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t + +(** Records a vote for a delegate, returns a {!Storage_error Existing_key} if + the vote was already registered *) +val record_ballot: + Raw_context.t -> Signature.Public_key_hash.t -> Vote_repr.ballot -> + Raw_context.t tzresult Lwt.t + +(** Computes the sum of the current ballots weighted by stake. *) +val get_ballots: Raw_context.t -> ballots tzresult Lwt.t +val get_ballot_list : + Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t +val clear_ballots: Raw_context.t -> Raw_context.t Lwt.t + +val listings_encoding : (Signature.Public_key_hash.t * int32) list Data_encoding.t + +(** Populates [!Storage.Vote.Listings] using the currently existing rolls and + sets Listings_size. Delegates without rolls are not included in the listing. *) +val freeze_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t +val clear_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t + +(** Returns the sum of all rolls of all delegates. *) +val listing_size: Raw_context.t -> int32 tzresult Lwt.t + +(** Verifies the presence of a delegate in the listing. *) +val in_listings: + Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t +val get_listings : Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t + +val get_current_quorum: Raw_context.t -> int32 tzresult Lwt.t +val set_current_quorum: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + +val get_current_period_kind: + Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t +val set_current_period_kind: + Raw_context.t -> Voting_period_repr.kind -> Raw_context.t tzresult Lwt.t + +val get_current_proposal: + Raw_context.t -> Protocol_hash.t tzresult Lwt.t +val init_current_proposal: + Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t +val clear_current_proposal: Raw_context.t -> Raw_context.t tzresult Lwt.t + +(** Sets the initial quorum to 80% and period kind to proposal. *) +val init: Raw_context.t -> Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml new file mode 100644 index 000000000..8124e10a0 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml @@ -0,0 +1,82 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = int32 +type voting_period = t +include (Compare.Int32 : Compare.S with type t := t) +let encoding = Data_encoding.int32 +let pp ppf level = Format.fprintf ppf "%ld" level +let rpc_arg = + let construct voting_period = Int32.to_string voting_period in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse voting period" + | voting_period -> Ok voting_period in + RPC_arg.make + ~descr:"A voting period" + ~name: "voting_period" + ~construct + ~destruct + () + +let root = 0l +let succ = Int32.succ + +let to_int32 l = l +let of_int32_exn l = + if Compare.Int32.(l >= 0l) + then l + else invalid_arg "Voting_period_repr.of_int32" + +type kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + +let kind_encoding = + let open Data_encoding in + union ~tag_size:`Uint8 [ + case (Tag 0) + ~title:"Proposal" + (constant "proposal") + (function Proposal -> Some () | _ -> None) + (fun () -> Proposal) ; + case (Tag 1) + ~title:"Testing_vote" + (constant "testing_vote") + (function Testing_vote -> Some () | _ -> None) + (fun () -> Testing_vote) ; + case (Tag 2) + ~title:"Testing" + (constant "testing") + (function Testing -> Some () | _ -> None) + (fun () -> Testing) ; + case (Tag 3) + ~title:"Promotion_vote" + (constant "promotion_vote") + (function Promotion_vote -> Some () | _ -> None) + (fun () -> Promotion_vote) ; + ] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli new file mode 100644 index 000000000..cabe40c99 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli @@ -0,0 +1,48 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** A voting period can be of 4 kinds and is uniquely identified as a counter + since the root. *) + +type t +type voting_period = t +val encoding: voting_period Data_encoding.t +val rpc_arg: voting_period RPC_arg.arg +val pp: Format.formatter -> voting_period -> unit +include Compare.S with type t := voting_period + +val to_int32: voting_period -> int32 +val of_int32_exn: int32 -> voting_period + +val root: voting_period +val succ: voting_period -> voting_period + +type kind = + | Proposal (** protocols can be proposed *) + | Testing_vote (** a proposal can be voted *) + | Testing (** winning proposal is forked on a testnet *) + | Promotion_vote (** activation can be voted *) + +val kind_encoding: kind Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml new file mode 100644 index 000000000..80a42a4cd --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml @@ -0,0 +1,138 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +module S = struct + + let path = RPC_path.(open_root / "votes") + + let ballots = + RPC_service.get_service + ~description:"Sum of ballots casted so far during a voting period." + ~query: RPC_query.empty + ~output: Vote.ballots_encoding + RPC_path.(path / "ballots") + + let ballot_list = + RPC_service.get_service + ~description:"Ballots casted so far during a voting period." + ~query: RPC_query.empty + ~output: Data_encoding.(list (obj2 + (req "pkh" Signature.Public_key_hash.encoding) + (req "ballot" Vote.ballot_encoding))) + RPC_path.(path / "ballot_list") + + let current_period_kind = + RPC_service.get_service + ~description:"Current period kind." + ~query: RPC_query.empty + ~output: Voting_period.kind_encoding + RPC_path.(path / "current_period_kind") + + let current_quorum = + RPC_service.get_service + ~description:"Current expected quorum." + ~query: RPC_query.empty + ~output: Data_encoding.int32 + RPC_path.(path / "current_quorum") + + let listings = + RPC_service.get_service + ~description:"List of delegates with their voting weight, in number of rolls." + ~query: RPC_query.empty + ~output: Vote.listings_encoding + RPC_path.(path / "listings") + + let proposals = + RPC_service.get_service + ~description:"List of proposals with number of supporters." + ~query: RPC_query.empty + ~output: (Protocol_hash.Map.encoding Data_encoding.int32) + RPC_path.(path / "proposals") + + let current_proposal = + RPC_service.get_service + ~description:"Current proposal under evaluation." + ~query: RPC_query.empty + ~output: (Data_encoding.option Protocol_hash.encoding) + RPC_path.(path / "current_proposal") +end + +let register () = + let open Services_registration in + + register0 S.ballots begin fun ctxt () () -> + Vote.get_ballots ctxt + end; + + register0 S.ballot_list begin fun ctxt () () -> + Vote.get_ballot_list ctxt >|= ok + end; + + register0 S.current_period_kind begin fun ctxt () () -> + Vote.get_current_period_kind ctxt + end; + + register0 S.current_quorum begin fun ctxt () () -> + Vote.get_current_quorum ctxt + end; + + register0 S.proposals begin fun ctxt () () -> + Vote.get_proposals ctxt + end; + + register0 S.listings begin fun ctxt () () -> + Vote.get_listings ctxt >|= ok + end; + + register0 S.current_proposal begin fun ctxt () () -> + (* this would be better implemented using get_option in get_current_proposal *) + Vote.get_current_proposal ctxt >>= function + | Ok p -> return_some p + | Error [Raw_context.Storage_error (Missing_key _)] -> return_none + | (Error _ as e) -> Lwt.return e + end + +let ballots ctxt block = + RPC_context.make_call0 S.ballots ctxt block () () + +let ballot_list ctxt block = + RPC_context.make_call0 S.ballot_list ctxt block () () + +let current_period_kind ctxt block = + RPC_context.make_call0 S.current_period_kind ctxt block () () + +let current_quorum ctxt block = + RPC_context.make_call0 S.current_quorum ctxt block () () + +let listings ctxt block = + RPC_context.make_call0 S.listings ctxt block () () + +let proposals ctxt block = + RPC_context.make_call0 S.proposals ctxt block () () + +let current_proposal ctxt block = + RPC_context.make_call0 S.current_proposal ctxt block () () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli new file mode 100644 index 000000000..0cb4599d7 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli @@ -0,0 +1,49 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val ballots : + 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t + +val ballot_list : + 'a #RPC_context.simple -> 'a -> (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t + +val current_period_kind : + 'a #RPC_context.simple -> 'a -> Voting_period.kind shell_tzresult Lwt.t + +val current_quorum : + 'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t + +val listings : + 'a #RPC_context.simple -> 'a -> (Signature.Public_key_hash.t * int32) list shell_tzresult Lwt.t + +val proposals : + 'a #RPC_context.simple -> 'a -> Int32.t Protocol_hash.Map.t shell_tzresult Lwt.t + +val current_proposal : + 'a #RPC_context.simple -> 'a -> Protocol_hash.t option shell_tzresult Lwt.t + +val register : unit -> unit diff --git a/vendors/ligo-utils/tezos-utils/michelson-parser/v1.ml b/vendors/ligo-utils/tezos-utils/michelson-parser/v1.ml index 1c203482c..6ab7945ad 100644 --- a/vendors/ligo-utils/tezos-utils/michelson-parser/v1.ml +++ b/vendors/ligo-utils/tezos-utils/michelson-parser/v1.ml @@ -24,6 +24,7 @@ (*****************************************************************************) open Memory_proto_alpha +open Protocol open Tezos_micheline open Micheline_parser open Micheline diff --git a/vendors/ligo-utils/tezos-utils/michelson-parser/v1.mli b/vendors/ligo-utils/tezos-utils/michelson-parser/v1.mli index 2f0980e32..567e54377 100644 --- a/vendors/ligo-utils/tezos-utils/michelson-parser/v1.mli +++ b/vendors/ligo-utils/tezos-utils/michelson-parser/v1.mli @@ -24,7 +24,7 @@ (*****************************************************************************) open Memory_proto_alpha -open Alpha_context +open Protocol.Alpha_context open Tezos_micheline diff --git a/vendors/ligo-utils/tezos-utils/tezos-utils.opam b/vendors/ligo-utils/tezos-utils/tezos-utils.opam index bf02c748c..02a2074f2 100644 --- a/vendors/ligo-utils/tezos-utils/tezos-utils.opam +++ b/vendors/ligo-utils/tezos-utils/tezos-utils.opam @@ -18,7 +18,6 @@ depends: [ "ezjsonm" "hex" "hidapi" - "ipaddr" "irmin" "js_of_ocaml" "lwt" @@ -35,7 +34,6 @@ depends: [ "ocplib-json-typed" "ocplib-json-typed-bson" "tezos-crypto" - "tezos-stdlib-unix" "tezos-data-encoding" "tezos-protocol-environment" "tezos-protocol-alpha" diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 254b93fab..6bb8e6203 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -1,7 +1,7 @@ open Tezos_micheline open Micheline -include Michelson_primitives +include Memory_proto_alpha.Protocol.Michelson_v1_primitives type michelson = (int, prim) node type t = michelson @@ -15,7 +15,7 @@ let annotate annot = function let seq s : michelson = Seq (0, s) -let i_comment s : michelson = prim ~annot:["\"" ^ s ^ "\""] I_NOP +let i_comment s : michelson = seq [ prim ~annot:["\"" ^ s ^ "\""] I_UNIT ; prim I_DROP ] let contract parameter storage code = seq [ @@ -73,8 +73,8 @@ let rec strip_annots : michelson -> michelson = function | x -> x let rec strip_nops : michelson -> michelson = function + | Seq(l, [Prim (_, I_UNIT, _, _) ; Prim(_, I_DROP, _, _)]) -> Seq (l, []) | Seq(l, s) -> Seq(l, List.map strip_nops s) - | Prim (l, I_NOP, _, _) -> Seq (l, []) | Prim (l, p, lst, a) -> Prim (l, p, List.map strip_nops lst, a) | x -> x